home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FishMarket 1.0
/
FishMarket v1.0.iso
/
fishies
/
126-150
/
disk_144
/
analyticalc
/
analysources.arc
/
AnalyF6.Ftn
< prev
next >
Wrap
Text File
|
1987-11-08
|
77KB
|
2,677 lines
c -h- varscn.for Fri Aug 22 13:37:17 1986
C $DO66
SUBROUTINE VARSCN(LINE,IBGN,LEND,LSTCHR,ID1,ID2,IVALID)
C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C
C VARSCN - SCAN COMMAND LINE FOR VARIABLE NAMES.
C
C SCANS FOR VARIABLE NAMES OF FORM AAANNN WHERE AAA = LETTERS
C BETWEEN A AND Z UP TO NON-ALPHA, CORRESPONDING TO ROW, FOLLOWED BY
C NUMBERS IN THE 0-9 RANGE MAKING A DECIMAL COLUMN NUMBER.
C
C THE LETTERS ARE FORMED BY
C A-Z ALONE GIVE ROW 1-26, COL 1. % IS ROW 27,COL1
C A1-Z1 GIVE ROW 1-26, COL 2
C AA1-ZZ1 ARE ROW 27-52, COL 2
IMPLICIT InTeGer*4 (A-Z)
C PARAMETER 18060=60*301 ! SIZE
C NOTE COL 1 IS DUMMY. DISPLAY THE SHEET SIDEWAYS SO WE GET USUAL VISUAL
C ROWS, COLS., AND ACCUMULATORS A-Z,% JUST APPEAR AS A FICTITIOUS ROW 0
C ON DISPLAY, INSTEAD OF REAL COLUMN 1 HERE.
DIMENSION LINE(LEND)
CHARACTER*1 LINE
InTeGer*4 TYPE(1,1),VLEN(9)
REAL*8 XVBLS(1,1)
CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
REAL*8 XAVB
REAL*4 XAV2(2)
CHARACTER*1 XAV1(8)
EXTERNAL INDX
EQUIVALENCE(XAVB,XAV2(1)),(XAVB,XAV1(1))
EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
COMMON/V/TYPE,AVBLS,VBLS,VLEN
C ***<<< KLSTO COMMON START >>>***
InTeGer*4 DLFG
C COMMON/DLFG/DLFG
InTeGer*4 KDRW,KDCL
C COMMON/DOT/KDRW,KDCL
InTeGer*4 DTRENA
C COMMON/DTRCMN/DTRENA
REAL*8 EP,PV,FV
DIMENSION EP(20)
INTEGER*4 KIRR
C COMMON/ERNPER/EP,PV,FV,KIRR
InTeGer*4 LASTOP
C COMMON/ERROR/LASTOP
CHARACTER*1 FMTDAT(9,76)
C COMMON/FMTBFR/FMTDAT
CHARACTER*1 EDNAM(16)
C COMMON/EDNAM/EDNAM
InTeGer*4 MFID(2),MFMOD(2)
C COMMON/FRM/MFID,MFMOD
InTeGer*4 JMVFG,JMVOLD
C COMMON/FUBAR/JMVFG,JMVOLD
COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
1 LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC InTeGer*4 DLFG
CCC COMMON/DLFG/DLFG
C DLFG=1 IF D## FORMS ARE SEEN
DIMENSION NRDSP(20,75),NCDSP(20,75)
COMMON/D2R/NRDSP,NCDSP
C NRDSP AND NCDSP ARE REAL ROW, COL OF DISPLAY ROW, COL CELLS. NOTE THAT
C NOT ALL DISPLAY CELLS ARE ALWAYS ACTUALLY SHOWN; ONLY THOSE THAT FIT
C ARE SHOWN; THE REST "EXIST" BUT DON'T APPEAR UNLESS ROWS ARE SMALL
C ENOUGH.
C
C THIS PROGRAM ALSO HANDLES CELL SPECS OF FORM
C P#+nnn#+nnn (or P#-nnn#-mmm) FOR Physical cells relative to our current
C physical cell on the sheet (clamped at boundaries), or of form
C D#+nnn#+mmm etc for Display cells relative to our current display
C location as held in the DROW,DCOL cells in commons.
C ***<<<< RDD COMMON START >>>***
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6
CCC common/dollr/idol1,idol2,idol3,idol4,idol5,idol6
CCC InTeGer*4 PROW,PCOL
C ! PHYSICAL ROW, COL BEING HANDLED.
CCC InTeGer*4 DROW,DCOL,DCLV,DRWV
InTeGer*4 RSM,CSM,AFG,ASM,VCF,CH
CCC COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
LOGICAL*4 L1,L2
C LOGICAL*2 L63,L192,L127
InTeGer*4 I1,I2
InTeGer*4 I63,I192,I127
EQUIVALENCE(I1,L1),(I2,L2)
C EQUIVALENCE (I63,L63),(I192,L192),(L127,I127)
DATA I63/63/,I192/192/,I127/127/
C DRWV,DCLV = # OF MAX ROWS, COLS ACTUALLY ON SCREEN NOW. DROW,DCOL
C ARE ACTUAL "CURSOR" LOCATION.
C
C ZERO OUR VARIABLES
LPFG=0
C ! FLAG WE GOT A LOGICAL/PHYSICAL # FORM AND TYPE
AFG=0
C ! FLAG WE SAW AN ALPHA
ASM=0
C ! SUM OF ALPHAS HASHCODED (ACCUMULATOR)
NSM=0
C ! ACCUMULATOR FOR NUMERICS
NFG=0
C ! FLAG WE SAW A NUMERIC
RSM=0
C ! AC FOR ROWS IN # FORMS
CSM=0
C ! AC FOR COLS IN # FORMS
ISPC=0
C ! COUNTER FOR NONSPACES SEEN (USED TO STOP ON TRAILING SPACES)
idol1=0
idol2=0
IF(LINE(IBGN).NE.'%')GOTO 2000
ID1=27
ID2=1
IVALID=1
LSTCHR=IBGN+1
C SPECIAL CASE FOR % = AC #27
RETURN
2000 CONTINUE
DO 1 N=IBGN,LEND
VCF=0
LSTCHR=N
CH=ICHAR(LINE(N))
IF (CH.EQ.255)GOTO 5000
C 5000 DECODES ENCODED FORMS AND RETURNS THEM...
C
C IGNORE SPACES AND TABS IF LEADING
IF(CH.GT.32)ISPC=ISPC+1
IF(CH.GT.0.AND.CH.LE.32.AND.ISPC.EQ.0)GOTO 1
C SPECIAL CASE TRAILING DOLLAR SIGNS... SKIP AND FLAG
IF(CH.NE.36)GOTO 3443
C 36 IS ASCII FOR $ SIGN
C SAW A DOLLAR SIGN
IF(AFG.EQ.1.AND.NFG.EQ.0)IDOL1=1
IF(AFG.EQ.1.AND.NFG.EQ.1)IDOL2=1
C LEAVES WITH IDOL1 FLAGGED AS 1 IF LETTER PART WAS FOLLOWED BY
C DOLLAR SIGN, AND IDOL2 FLAGGED IF NUMBER PART WAS FOLLOWED
C BY DOLLAR. IGNORES ALL OTHER DOLLAR SIGNS.
GOTO 1
3443 CONTINUE
C GET CHARACTER VALUE IN.
C MUST BE UPPERCASE.
IF(.NOT.(CH.GE.65.AND.CH.LT.91)) GOTO 100
C CH IS AN ALPHA, RANGE A-Z
VCF=1
C ! VALID CHAR SEEN
AFG=1
C !SAW THE ALPHA
IF(ASM.LT.18060)ASM=(CH-64)+26*ASM
IF(NFG.NE.0)GOTO 103
C FILTER OUT TOO-LARGE VALUES...
IF(ASM.GT.18000)GOTO 103
C 60 * 26 IS LIM ABOVE
IF(CH.EQ.80)LPFG=1
C ! FLAG WE GOT PHYS. FORM MAYBE
IF(CH.EQ.68)LPFG=2
C ! FLAG WE GOT DISPLAY FORM MAYBE
100 CONTINUE
C EXPECT # FORMS TO HAVE # JUST AFTER 1ST ALPHA.
C 35 IS ASCII VALUE OF '#' CHAR.
IF(CH.EQ.35)GOTO 1000
C NEXT TEST NUMERICS
IF(.NOT.(CH.GE.48.AND.CH.LE.57))GOTO 101
C CH IS A NUMERIC, RANGE 0-9
VCF=1
C ! VALID CHAR SEEN
NFG=1
C ! FLAG WE SAW NUMERIC
IF(AFG.NE.0)GOTO 102
GOTO 103
102 CONTINUE
IF(NSM.LT.18060)NSM=(CH-48)+10*NSM
C FILTER OUT TOO-LARGE VALUES EARLY
C 301 * 10 IS LIMIT...
IF(NSM.GT.18000)GOTO 103
C ! CONVERT CHARS TO BINARY AS SEEN
101 CONTINUE
IF(VCF.EQ.0)GOTO 2
C !END ON ANY INVALID CHARACTER
1 CONTINUE
2 CONTINUE
IF(AFG.EQ.0)GOTO 103
GOTO 950
103 CONTINUE
C INVALID ... NUMERIC AND NO PRIOR ALPHA. FLAG BAD NAME AND EXIT.
IVALID=0
RETURN
950 ID1=ASM
ID2=1+NSM
C ! NOTE ID2=1 IF NO NUMERICS SEEN, MORE OTHERWISE.
GOTO 1201
1000 CONTINUE
C HERE HANDLE CURRENT-REFERENCED FORMS USING # AS SPECIAL CHARACTER MEANING
C THE CURRENT POSITION. THESE TYPES OF REFERENCES MAY BE MOVED AROUND THE
C SHEET WHICH ACCOUNTS FOR THEIR USEFULNESS. SINCE THERE IS A DISPLAY
C AND PHYSICAL SHEET WHICH ARE MAPPED BY A MAPPING, ALLOW EITHER
C TO BE REFERENCED. THUS, COMPLEX CALCULATIONS MAY BE DONE BUT LARGELY
C HIDDEN. THE ACCUMULATORS MAY BE USED AS SCRATCH STORAGE FOR THIS
C SORT OF THING.
C SAW THE # SIGN, SO SEE IF THE + OR - N CAN BE DECODED.
C IF NO P OR D WAS SEEN HOWEVER WE HAVE AN INVALID NAME, SO FLAG IT.
IF(LPFG.EQ.0)GOTO 103
C PASS THE # SIGN PRIOR TO GETTING THE NUMERIC.
LSTCHR=LSTCHR+1
if(line(lstchr).ne.'%')goto 3900
c allow p#%ab form to mean use ac a and b to get offsets from "here"
CSM=0
RSM=0
C DEFAULT TO "THIS" CELL
LSTCHR=LSTCHR+1
C PASS THE % SIGN
RSM=ICHAR(LINE(LSTCHR))
CSM=ICHAR(LINE(LSTCHR+1))
LSTCHR=LSTCHR+2
C FIX UP ASCII OFFSETS, AND MEANWHILE REQUIRE UPPERCASE
C AND THAT THERE BE 2 AC'S NAMES AFTER THE %.
C THIS SHOULD BE HANDY FOR COMMAND FILES.
RSM=RSM-64
CSM=CSM-64
C NOW RSM, CSM ARE SUBSCRIPTS. PULL OUT VALUES FROM XVBLS
IF(RSM.LE.0.OR.RSM.GT.27)GOTO 103
IF(CSM.LE.0.OR.CSM.GT.27)GOTO 103
DO 3902 IV=1,8
3902 XAV1(IV)=AVBLS(IV,RSM)
RSM=XAVB
DO 3903 IV=1,8
3903 XAV1(IV)=AVBLS(IV,CSM)
CSM=XAVB
C LOADS THE 2 AC'S TO THE OFFSETS AND GOES ON...JUST NEEDS THE
C 2 LETTERS AFTER P#% OR D#%.
goto 3901
3900 continue
CALL GN(LSTCHR,LEND,NUM,LINE)
C GN GETS THE +- NN NUMBER AND RETURNS VALUE IN NUM.
C LSTCHR RETURNS AS NEXT CHAR NOT USED.
RSM=NUM
C 35 IS ASCII FOR '#'
C allow any delimiter between numbers, though we must have # at start
C to delimit valid relative coordinates.
C IF(ICHAR(LINE(LSTCHR)).NE.35) GOTO 103
C IF NO SECOND # SEEN, THE FORM IS INVALID SO SAY SO AND EXIT.
LSTCHR=MIN0(LSTCHR+1,LEND)
CC BUMP PAST THE # IF WE SAW IT.
C now get the second numeric string and bump LSTCHR past it.
NUM=0
CALL GN(LSTCHR,LEND,NUM,LINE)
CSM=NUM
C NOW HAVE THE NUMBERS ENCODED. NOTE THAT ## IS VALID.
3901 CONTINUE
IF(LPFG.EQ.2) GOTO 1200
C IF HERE, LPFG=1 AND WE ARE ON PHYSICAL SHEET.
ID2=CSM+PCOL
ID1=RSM+PROW
1201 CONTINUE
C TO ALLOW REFLECTED VALUES TO WORK, LET ALL NORMAL VALUES BY...
C IF(ID1.GT.60.OR.ID1.LE.0)GOTO 103
C IF(ID2.GT.301.OR.ID2.LE.0)GOTO 103
IVALID=1
C ALL IS WELL
RETURN
1200 CONTINUE
C DISPLAY COLUMN RELATIVE.
DLFG=1
C FLAG WE SAW A D## FORM FOR RECALC
DRRW=DROW+RSM
DRRW=MAX0(1,DRRW)
DRRW=MIN0(20,DRRW)
DCCL=DCOL+CSM
C ENSURE DISPLAY COORDS IN LEGAL BOUNDS
DCCL=MAX0(1,DCCL)
DCCL=MIN0(75,DCCL)
C CLAMP TO WITHIN LEGAL DIMENSIONS.
ID1=NRDSP(DRRW,DCCL)
ID2=NCDSP(DRRW,DCCL)
GOTO 1201
5000 CONTINUE
IF(ASM.NE.0.OR.NSM.NE.0)GOTO 103
C HANDLE 255,CODE1,CODE2 FORMS
C FIRST BYTE IS ALWAYS 255
C 2ND BYTE IS: HI 2 BITS ARE HI 2 BITS OF ID2. LO 6 BITS ARE ID1
C 3RD BYTE IS: LO 8 BITS OF ID2
I1=ICHAR(LINE(LSTCHR+1))
I2=IMASK(I1,I192)
C L2=L1.AND.L192
C L1=L1.AND.L63
I1=IMASK(I1,I63)
ID1=I1
I1=ICHAR(LINE(LSTCHR+2))
C L1=L1.AND.L127
I1=IMASK(I1,I127)
C MUST HAVE 128 BIT ON IN LOW BYTE TO AVOID NULLS IN IT.
ID2=I2*2+I1
LSTCHR=LSTCHR+3
GOTO 1201
END
c -h- vvary.for Fri Aug 22 13:37:17 1986
C $DO66
C VARY CONTROL ROUTINE
C NOTE: THIS ROUTINE RELIES UPON HAVING ITS DATA AREAS REMAIN INTACT
C ACROSS CALLS. IT MUST NOT BE IN AN OVERLAY SEGMENT OR THAT WILL FAIL
C AND IT WILL NOT WORK. SPECIFICALLY IT EXPECTS THE AC ARRAY TO BE
C SET CORRECTLY.
SUBROUTINE VVARY(LINE,RETCD,K)
CHARACTER*1 LINE(80)
INTEGER RETCD
CHARACTER*1 AVBLS(20,27),WRK(128),VBLS(8,1,1)
InTeGer*4 TYPE(1,1),VLEN(9)
REAL*8 XAC,XVBLS(1,1)
EQUIVALENCE(XAC,AVBLS(1,27))
INTEGER*4 JVBLS(2,1,1)
EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
COMMON/V/TYPE,AVBLS,VBLS,VLEN
C LOOP CONTROL FOR VARY FUNCTION. SET ZERO IN SPREDSHT AND
C MUST BE SET POSITIVE HERE IF WE NEED ITERATIONS.
C (IMPLEMENT FOR VAX ONLY)
C ***<<< XVXTCD COMMON START >>>***
CHARACTER*1 OARRY(100)
InTeGer*4 OSWIT,OCNTR
C COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
C InTeGer*4 IPS1,IPS2,MODFLG
InTeGer*4 IC1POS,IC2POS,MODFLG
CCC COMMON/ICPOS/IC1POS,IC2POS,MODFLG
C COMMON/ICPOS/IPS1,IPS2,MODFLG
InTeGer*4 XTCFG,IPSET,XTNCNT
CHARACTER*1 XTNCMD(80)
C COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
INTEGER KALKIT
C COMMON/VARYIT/KALKIT
InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
InTeGer*4 RCMODE,IRCE1,IRCE2
C COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C 1 IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C AND VM INHIBITS. (SETS TO 1).
INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C COMMON/CONSFH/FH
CHARACTER*1 ARGSTR(52,4)
C COMMON/ARGSTR/ARGSTR
COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
1 XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
2 FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
3 IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC INTEGER KALKIT
CCC COMMON/VARYIT/KALKIT
EXTERNAL SIGN
INTEGER LPUT,LGET
REAL*8 SIGN
CHARACTER*1 LAC(8)
REAL*8 XVAC,VW
EQUIVALENCE(LAC(1),XVAC)
REAL *8 AC(26)
REAL*8 DERIV(8)
REAL*8 DEL(8)
REAL*8 OLDVV,OLDX,OLDA
INTEGER ACV(8)
INTEGER CAC
INTEGER CCNT(8)
C UNCOMMENT THIS COMMON DECLARATION AND MOVE DATA STMTS INTO BLOCK
C IN ORDER TO OVERLAY THIS...
COMMON/VRYDAT/AC,DERIV,DEL,CAC,CCNT,OLDVV,OLDX,OLDA,ACV
C
C ACV POINTS TO AC'S VARYING
C CAC = CURRENT INDEX INTO ACV TO FIND AC BEING VARIED
C AC IS LAST SET OF ACCUMULATORS SEEN
C IF ACV ENTRY IS 0, MEANS NO AC TO VARY THERE.
INTEGER LW,LX,LI
C ! LOGICAL W,X,I AC'S
INTEGER LA
C ! LOGICAL A AC
C
C DATA DERIV/8*1./,DEL/8*0./
C DATA CAC/1/,CCNT/8*0/
C DATA ACV/8*0/
C DATA OLDVV/1./
C
C PARSE ARGUMENTS FIRST
C FIRST 2 ARGS ARE X AND A AC'S (OR GENERAL CELLS)
C DEFAULT NO REDOING THIS...
KALKIT=0
IBGN=K+5
LEND=IBGN+20
CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LX,ID2A,IVALID)
IF (IVALID.EQ.0)GOTO 9900
IF(LINE(LSTCHR).NE.',')GOTO 9900
IBGN=LSTCHR+1
LEND=IBGN+20
CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LA,ID2B,IVALID)
IF (IVALID.EQ.0)GOTO 9900
IF(LINE(LSTCHR).NE.',')GOTO 9900
IBGN=LSTCHR+1
LEND=IBGN+20
CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LW,ID3B,IVALID)
IF (IVALID.EQ.0)GOTO 9900
IF(LINE(LSTCHR).NE.',')GOTO 9900
IF(ID3B.NE.1)GOTO 9900
IBGN=LSTCHR+1
LEND=IBGN+20
CALL VARSCN(LINE,IBGN,LEND,LSTCHR,LI,ID3B,IVALID)
IF (IVALID.EQ.0)GOTO 9900
IF(LINE(LSTCHR).NE.',')GOTO 9900
IF(ID3B.NE.1)GOTO 9900
C IBGN=LSTCHR+1
C LEND=IBGN+20
C LOOP OVER VALUES TO VARY NOW
DO 99 N=1,8
99 ACV(N)=0.
DO 100 N=1,8
C ALLOW UP TO 8 DIMENSIONS VARIATION
IBGN=LSTCHR+1
LEND=IBGN+20
CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ACV(N),ID3B,IVALID)
IF (IVALID.EQ.0)GOTO 9900
IF(LINE(LSTCHR).NE.';')GOTO 110
IF(ID3B.NE.1)GOTO 9900
IBGN=LSTCHR+1
LEND=IBGN+20
100 CONTINUE
110 CONTINUE
C NOW HAVE ALL AC POINTERS SET UP.
C IF I IS NOW 0 OR NEGATIVE (ITER COUNT), REINITIALIZE.
ASSIGN 111 TO LGET
LLL=LI
GOTO 500
111 CONTINUE
IF(XVAC.GT.0.)GOTO 112
C INITIALIZE COUNTS
LLL=LW
C GET VALUE OF W FRACTION
ASSIGN 114 TO LGET
GOTO 500
114 CONTINUE
VW=XVAC
OLDVV=1.
DO 113 N=1,8
CCNT(N)=0
DERIV(N)=1.
DEL(N)=VW
113 CONTINUE
CAC=1
C COPY CURRENT AC'S INTO SAVED ONES NOW.
DO 117 N=1,26
LLL=N
ASSIGN 118 TO LGET
GOTO 500
118 AC(N)=XVAC
117 CONTINUE
C AFTER THE INIT, JUST RETURN SINCE WE DON'T WANT TO TRY ANY ITERATIONS
C WHEN ITER COUNT EXPIRES.
KALKIT=0
RETURN
C HERE WHEN ITER COUNT IS POSITIVE.
112 CONTINUE
XVAC=XVAC-1.
C UPDATE ITERATION COUNT NOW...
KALKIT=XVAC
ASSIGN 120 TO LPUT
GOTO 600
120 CONTINUE
C
C NOW PROCEED WITH VARIATIONS...
IF(CAC.LT.1.OR.CAC.GT.8)CAC=1
IF(CCNT(CAC).GE.1)GOTO 200
C CCNT WAS 0 SO WE DIDN'T GET OUR PARTIAL YET. VARY THE
C AC WE'RE LOOKING AT (CAC = CURRENT AC) AND USE NEW VALUE OF
C (X-A) FOR A NUMERICAL DERIVATIVE RESULT AFTER A RECALC OF SCREEN...
CCNT(CAC)=1
C JUST STARTED THIS AC SO VARY BY THE APPROPRIATE DELTA AND
C EXIT, ALLOWING PARTIAL TO BE COMPUTED NEXT TIME.
LLL=LW
ASSIGN 400 TO LGET
GOTO 500
400 CONTINUE
C GET W ACC. VALUE
VW=XVAC
IF(VW.EQ.0.)VW=.5
C GET CURRENT AC, FIND HOW TO UPDATE IT.
LLL=ACV(CAC)
IF(LLL.LE.0)GOTO 9900
ASSIGN 121 TO LGET
GOTO 500
121 CONTINUE
C NOW XVAC HAS CURRENT AC FOR THE ONE WE'RE VARYING
C ADD DEL TO IT AND GET NEW ONE...
C SAVE OLD X AC VALUE FOR NEXT ITERATION.
C NOTE LLL IS STILL SET AT CURRENTLY VARYING AC
C SAVE CURRENT (UNVARIED) VALUE TOO FOR NEXT TIME AROUND.
OLDVV=XVAC
IF(OLDVV.EQ.0.)OLDVV=1.
IF(DEL(CAC).EQ.0.)DEL(CAC)=VW
XVAC=XVAC*(1.+DEL(CAC))
C NOW ALL SET... JUST SAVE CURRENT AC'S AND CURRENT X,A
C SO WE CAN GET DIFFERENCE NEXT TIME AROUND.
C AC(ACV(CAC))=XVAC
C STORE XVAC INTO REAL ACCUMULATORS TOO, SO IT'LL WORK
C WHEN ALL AC'S ARE RELOADED BELOW.
ASSIGN 412 TO LPUT
GOTO 600
412 CONTINUE
C AT 1000, RELOAD AC ARRAY FROM REAL AC'S... BUT GET OUR MODIFIED
C ONE WE JUST STORED TOO.
GOTO 1000
200 CONTINUE
C COUNT HERE IS 1 SO WE ALREADY HAVE INFO NOW FOR OUR PARITAL
C DERIVATIVE. COMPUTE IT AND VARY THE SELECTED AC USING IT
C THEN STORE IT AND RESET CCNT(CAC) TO 0
CCNT(CAC)=0
C MUST GET NEW X AND A VALUES NOW.
CALL XVBLGT(LX,ID2A,XVAC)
C XVAC=XVBLS(LX,ID2A)
IF(ID2A.NE.1)GOTO 201
LLL=LX
ASSIGN 201 TO LGET
C EXTRACT CURRENT X FROM AVBLS
GOTO 500
201 CONTINUE
XCURR=XVAC
CALL XVBLGT(LA,ID2B,XVAC)
C XVAC=XVBLS(1,1)
IF(ID2B.NE.1)GOTO 202
LLL=LA
ASSIGN 202 TO LGET
GOTO 500
202 CONTINUE
ACURR=XVAC
C NOW WE HAVE ENOUGH TO COMPUTE PARTIAL DERIVATIVE WE NEED.
IF(ACV(CAC).LE.0)GOTO 9900
IF(OLDVV.EQ.0.)OLDVV=AC(ACV(CAC))
IF(OLDVV.EQ.0.)OLDVV=1.
DERIV(CAC)=((XCURR-ACURR)-(OLDX-OLDA))/(DEL(CAC)*OLDVV)
C NEGATIVE FEEDBACK: IF GOING POSITIVE, MAKE IT NEGATIVE...
C THIS IS NOT AN ANALYTICAL PROCEDURE ... JUST STEPS IN RIGHT DIRECTION
C BY APPROPRIATE AMOUNT AND CONTINUES...
C CLAMP VARIATION TO INITIAL PERCENTAGE IN W ACCUMULATOR
LLL=LW
C OBTAIN VALUE OF W VARIATION NOW...IN CASE USER SETS IT UP TO VARY
ASSIGN 203 TO LGET
GOTO 500
203 CONTINUE
VW=XVAC
C
C TO ATTEMPT TO GET TO THE ZERO OF (X-A), WE REALLY NEED TO
C DIVIDE BY THE DERIVATIVE. HOWEVER, IN CASES WHERE THE FUNCTION
C IS NEAR ITS LOCAL MINIMUM AND SLOWLY VARYING, WE REALLY DON'T WANT
C TO STEP FAR AWAY (IT MAY NEVER REACH THE ZERO). THEREFORE, TEST
C TO SEE IF THE DERIVATIVE IS LARGE AND ALLOW DIVISION WHERE IT IS
C OVER A SOMEWHAT ARBITRARY THRESHOLD (USED 1.0 BELOW), BUT
C MULTIPLY BY DERIVATIVE OTHERWISE, SO THAT AS THE FUNCTION APPROACHES
C ZERO SLOPE, THE STEPS GET FINER TO GET INTO THE LOCAL MINIMUM (IF ANY).
C
C FORCE NONZERO VARIATION JUST SO WE DON'T GET STUCK.
IF(DERIV(CAC).EQ.0.)DERIV(CAC)=.01
IF(DABS(DERIV(CAC)).GT.1.)GOTO 405
DEL(CAC)=-(OLDX-OLDA)*VW*DERIV(CAC)
GOTO 406
405 CONTINUE
DEL(CAC)=-(OLDX-OLDA)*VW/DERIV(CAC)
406 CONTINUE
C VERY IMPORTANT TO CLAMP SIZE OF STEPS HERE SO WE DON'T WILDLY DIVERGE
C IN EARLY GOING. SMALL STEPS TAKE LONGER BUT GET TO MINIMA; LARGER ONES
C WHERE WE DON'T KNOW FUNCTION SHAPE CAN BE DISASTERS.
IF(DABS(DEL(CAC)).GT.VW)DEL(CAC)=VW*SIGN(DEL(CAC))
C NOW RESTORE AC'S TO OLD ONES AND VARY CURRENT ONE BY
C THE NEW DELTA.
IF(ACV(CAC).LE.0)GOTO 9900
C NEXT LINE MAKES ADJUSTMENT NEEDED TO OUR VARYING AC.
AC(ACV(CAC))=OLDVV*(1.+DEL(CAC))
C NOW COPY SAVED OLD AC'S ONTO NEW ONES SO WE START WITH AC'S ALL AS THEY
C WERE IN FIRST STEP SO WE VARY FROM INITIAL X, NOT FROM FIRST VARIED X
C LOCATION...
DO 204 N=1,26
XVAC=AC(N)
LLL=N
ASSIGN 205 TO LPUT
GOTO 600
205 CONTINUE
204 CONTINUE
C MOVE ON TO THE NEXT CAC VALUE
CAC=CAC+1
IF(ACV(CAC).LE.0.OR.CAC.GT.8)CAC=1
1000 CONTINUE
C SAVE OLD AC'S NOW FOR NEXT TIME
DO 1100 N=1,26
LLL=N
ASSIGN 1101 TO LGET
GOTO 500
1101 AC(N)=XVAC
1100 CONTINUE
C REMEMBER OLD X AND A VALUES SINCE WE LOOK FOR X=A AS
C A SEARCH CONDITION. WE MUST ASSUME THAT SOME SORT OF
C VARIATION OF ACCUMULATORS GIVEN WILL ALLOW US TO SATISFY
C THE EQUATION (X-A)=0.
OLDX=AC(LX)
IF(ID2A.NE.1)CALL XVBLGT(LX,ID2A,OLDX)
C IF(ID2A.NE.1)OLDX=XVBLS(LX,ID2A)
OLDA=AC(LA)
IF(ID2B.NE.1)CALL XVBLGT(LA,ID2B,OLDA)
C IF(ID2B.NE.1)OLDA=XVBLS(LA,ID2B)
RETURN
9900 CONTINUE
RETCD=3
RETURN
C PROC TO LOAD XVAC WITH VBLS(LLL)
500 CONTINUE
DO 501 KKKKN=1,8
501 LAC(KKKKN)=AVBLS(KKKKN,LLL)
GOTO LGET,(111,114,118,400,121,201,202,203,1101)
C PROC TO STORE XVAC INTO VBLS(LLL)
600 CONTINUE
DO 601 KKKKN=1,8
601 AVBLS(KKKKN,LLL)=LAC(KKKKN)
GOTO LPUT,(120,412,205)
END
c -h- xqtcmd.for Fri Aug 22 13:45:23 1986
C $DO66
SUBROUTINE XQTCMD(ICODE)
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
c All Rights Reserved
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
CHARACTER*1 FORM,FVLD,CMDLIN(132),CL127(127)
C ALLOCATE EXTRA SLOP SPACE AFTER CMDLIN
CHARACTER*1 CLWW(136)
EQUIVALENCE(CLWW(1),CMDLIN(1))
CHARACTER*127 CMDLNA
EQUIVALENCE(CMDLIN(1),CL127(1),CMDLNA(1:1))
C EQUIVALENCE(CMDLNA,CMDLIN(1))
CHARACTER*127 WRKCHR,FORMCH,fwt
C equivalence(fwt(1:1),formch(1:1))
CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
CHARACTER*1 WRKCHA(132),WRK127(127)
EQUIVALENCE(WRKCHA(1),WRKCHR(1:1),WRK127(1),FORM2(1))
C EQUIVALENCE(FORM2(1),WRK127(1))
C ***<<<< RDD COMMON START >>>***
InTeGer*4 RRWACT,RCLACT
C COMMON/RCLACT/RRWACT,RCLACT
InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8
C common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C 1 IDOL7,IDOL8
InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
InTeGer*4 KLVL
C COMMON/KLVL/KLVL
InTeGer*4 IOLVL,IGOLD
C COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
1 IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
2 IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC InTeGer*4 RRWACT,RCLACT
CCC COMMON/RCLACT/RRWACT,RCLACT
INTEGER*4 VNLT
EXTERNAL INDX
c EQUIVALENCE(FORM2(1),WRKCHR)
COMMON/NMSH/NMSH
REAL*8 XVBLS(1,1)
INTEGER KPYBAK
CCC Integer*4 FH
CCC Common/CONSFH/FH
C ***<<< KLSTO COMMON START >>>***
InTeGer*4 DLFG
C COMMON/DLFG/DLFG
InTeGer*4 KDRW,KDCL
C COMMON/DOT/KDRW,KDCL
InTeGer*4 DTRENA
C COMMON/DTRCMN/DTRENA
REAL*8 EP,PV,FV
DIMENSION EP(20)
INTEGER*4 KIRR
C COMMON/ERNPER/EP,PV,FV,KIRR
InTeGer*4 LASTOP
C COMMON/ERROR/LASTOP
CHARACTER*1 FMTDAT(9,76)
C COMMON/FMTBFR/FMTDAT
CHARACTER*1 EDNAM(16)
C COMMON/EDNAM/EDNAM
InTeGer*4 MFID(2),MFMOD(2)
C COMMON/FRM/MFID,MFMOD
InTeGer*4 JMVFG,JMVOLD
C COMMON/FUBAR/JMVFG,JMVOLD
COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
1 LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC InTeGer*4 JMVFG,JMVOLD
INTEGER*4 JVBLS(2,1,1)
CCC COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
C PUT JMVFG INTO A PSECT BY ITSELF SO IT WILL SURVIVE OVERLAYS.
CCC COMMON/FUBAR/JMVFG,JMVOLD
DIMENSION FORM(128),FVLD(1,1)
CHARACTER*1 DFE,FVWRK,FVWRK2,FRM127(127)
EQUIVALENCE(FORM(1),FORMCH(1:1),FRM127(1))
C EQUIVALENCE(FORM(1),FRM127(1)),(FRM127(1),FORMCH)
DIMENSION DFE(14)
CHARACTER*14 CDFE
EQUIVALENCE(CDFE(1:1),DFE(1))
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
CCC InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6,
CCC 1 IDOL7,IDOL8
CCC COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6,
CCC 1 IDOL7,IDOL8
CCC InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC InTeGer*4 LLCMD,LLDSP
CCC COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
DIMENSION NRDSP(20,75),NCDSP(20,75)
COMMON/D2R/NRDSP,NCDSP
InTeGer*4 ILNFG,ILNCT,RCF
C ***<<< NULETC COMMON START >>>***
InTeGer*4 ICREF,IRREF
C COMMON/MIRROR/ICREF,IRREF
InTeGer*4 MODPUB,LIMODE
C COMMON/MODPUB/MODPUB,LIMODE
InTeGer*4 KLKC,KLKR
REAL*8 AACP,AACQ
C COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
InTeGer*4 NCEL,NXINI
C COMMON/NCEL/NCEL,NXINI
CHARACTER*1 NAMARY(20,301)
C COMMON/NMNMNM/NAMARY
InTeGer*4 NULAST,LFVD
C COMMON/NULXXX/NULAST,LFVD
COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
1 KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC COMMON/NCEL/NCEL,NXINI
CHARACTER*1 ILINE(106)
COMMON/ILN/ILNFG,ILNCT,ILINE
C ***<<< XVXTCD COMMON START >>>***
CHARACTER*1 OARRY(100)
InTeGer*4 OSWIT,OCNTR
C COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
C InTeGer*4 IPS1,IPS2,MODFLG
InTeGer*4 IC1POS,IC2POS,MODFLG
CCC COMMON/ICPOS/IC1POS,IC2POS,MODFLG
C COMMON/ICPOS/IPS1,IPS2,MODFLG
InTeGer*4 XTCFG,IPSET,XTNCNT
CHARACTER*1 XTNCMD(80)
C COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
INTEGER KALKIT
C COMMON/VARYIT/KALKIT
InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
InTeGer*4 RCMODE,IRCE1,IRCE2
C COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C 1 IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C AND VM INHIBITS. (SETS TO 1).
INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C COMMON/CONSFH/FH
CHARACTER*1 ARGSTR(52,4)
C COMMON/ARGSTR/ARGSTR
COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IC1POS,IC2POS,MODFLG,
1 XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
2 FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
3 IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC InTeGer*4 IC1POS,IC2POS,MODFLG
CCC COMMON/ICPOS/IC1POS,IC2POS,MODFLG
CCC CHARACTER*1 OARRY(100)
CCC InTeGer*4 OSWIT,OCNTR
CCC COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
InTeGer*4 TYPE(1,1),VLEN(9)
CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
CHARACTER*1 FVLDTP
REAL*8 XAC,ZAC
EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
REAL*8 XXAC,XYAC
EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
CCC InTeGer*4 NULAST,LFVD
CCC COMMON/NULXXX/NULAST,LFVD
CCC CHARACTER*1 ARGSTR(52,4)
CCC COMMON/ARGSTR/ARGSTR
C EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC COMMON/KLVL/KLVL
CHARACTER*1 DEFVB(12)
CCC InTeGer*4 MODPUB,LIMODE
CCC COMMON/MODPUB/MODPUB,LIMODE
COMMON/DEFVBX/DEFVB
CCC InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCC 1 IRCE1,IRCE2
CCC COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCC 1 IRCE1,IRCE2
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C AND VM INHIBITS. (SETS TO 1).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
REAL*8 DVS(20,75)
INTEGER*4 LDVS(2,20,75)
EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
COMMON /FVLDC/FVLD
C CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
COMMON/DSPCMN/DVS,CWIDS
C THISRW,THISCL = CURRENT DISPLAYED LOCS.
InTeGer*4 THISRW,THISCL
C CHARACTER*1 IBITMP(2258)
C COMMON/INITD/IBITMP
C FOLLOWING COMMON IS TO CONTROL "EXTERNAL" CALL OF XQTCMD
C TO ALLOW USE FROM INSIDE CELLS.
CCC CHARACTER*1 XTNCMD(80)
CCC InTeGer*4 XTCFG,XTNCNT,IPSET
CCC COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
CHARACTER*1 blanks
dimension blanks(30)
data blanks/30*' '/
C
OSWIT=2
C ISSUE A PROMPT FOR COMMAND AND DO A COMMAND
C
C COMMANDS INCLUDE:
C E = ENTER NUMBERS OR FORMULAS
C M = MOVE DIRECTION (1,2,3,4 = U,D,L,R)
C D = DISPLAY CHARACTERISTIC CHANGES
C
C DISPLAY ALTERING SUBCOMMANDS:
C DL V1:V2 RN:M OR CN:M - DISPLAY VARIABLE RANGE V1:V2 AT DISPLAY
C ROW OR COL N THRU M.
C RN:M MEANS ACROSS A ROW ON DISPLAY STARTING AT DISPLAY COORD N,M
C CN:M MEANS DOWN A DISPLAY COLUMN STARTING AT DISPLAY COORD N,M
C DF V1:V2 FORMAT
C SET FORMAT FOR DISPLAY OF V1 THRU V2 TO FORMAT (NOT INCL. )
C A OR L DESIGNATOR SAYS SHOW TEXT IN FORMULA BUFFER. ELSE SHOW
C NUMBER VALUE AT THAT LOC.
C DT V1:V2 F OR I - SET NUMERIC TYPE OF V1 THRU V2 TO FLOAT OR INT.
C DW N,M - SET WIDTH OF COL. N TO M CHARS WIDE.
C DB MC,MR - SET MAX COLS TO MC, MAX ROWS TO MR.
C
C V = VIEWSCREEN UPDATE. REDISPLAY EVERYTHING FROM SCRATCH.
C VF = VIEW BUT DISPLAY FORMULAS ALL LOCS.
C VM = DISABLE REDRAWING SCREEN UNTIL A V IS SEEN.
C C = COPY NUMBERS/FORMULAS/DISPLAY STUFF(FORMAT)/ALL/RELOCATING
C 1,2,3,4 = MOVE CURSOR UP,DOWN,LEFT,RIGHT 1 ROW/COL
C (THESE DO NOT INVALIDATE CALCULATION SO RECALCULATION IS NOT
C DONE FOR THESE COMMANDS.)
C F FILENAME/NNN FILL SCREEN (DISPLAYED PART ONLY) FROM FILENAME,
C SKIPPING NNN RECORDS FIRST IF CALLED FOR. /NNN PART OPTIONAL.
C (SPLITS STUFF READ IN ACROSS COLUMNS CURRENTLY DEFINED AND
C SETS FVLD FOR DISPLAY OF TEXT, NOT #S.)
C AR/A n R/C ADDS/SUBTRACTS (INSERTS/DELETES) n ROWS OR COLUMNS
C AT CURENT LOCATION. AR/AA SELECTS RELOCATING/ABSOLUTE.
C R = RECALCULATE SHEET. 17 = RECALCULATE MANUALLY ONLY (R RESETS)
C K = DROP INTO CALC CALCULATOR (*E RETURNS TO SHEET)
C L = LOCATE CURSOR (MOVE TO POSITION ON SHEET)
C (L VARIABLE IS THE COMMAND, AND IT LOCATES ORIGIN ON PHYSICAL
C SHEET. WILL ALSO MOVE CURSOR ON DISPLAY SHEET IF THAT CELL IS
C DISPLAYED, BUT OTHERWISE DOES NOT DISPLAY THE NUMBER.)
C Z = ZERO FORMULA/NUMBERS (OR ALL SHEET)
C ZERO VARIABLE ZEROES THAT VARIABLE
C ZERO VARIABLE1:VARIABLE2 ZEROES THAT RANGE (ROW OR COL)
C ZERO * ZEROES ALL OF THE SHEET.
C X = EXIT (RETURNS TO OS)
C P = PUT NUMBERS TO FILE. ALWAYS GENERATES P#+nn#+mm forms based on
C current location.
C G = GET NUMBERS OUT OF FILE. USES CURRENT ORIGIN FROM L COMMAND OR 1,1
C TO ENTER NUMBERS (ALLOWS COMBINING DATA).
C W = WRITE SCREEN ON PRINTER (HARDCOPY FORMAT APPROX. AS DISPLAY.)
C OA VARIABLE = SET ORIGIN OF DISPLAY SHEET TO VARIABLE LOC IN
C PHYSICAL SHEET (CLAMPED TO MAX. SIZE OF SHEET). STARTS AT R1,C1 OF
C DISPLAY SHEET.
C OR VARIABLE = SET ORIGIN OF DISPLAY SHEET TO LOC'N OF VARIABLE IN
C PHYSICAL SHEET. MODIFIES DISPLAY SHEET STARTING AT CURRENT DISPLAY
C LOCATION RATHER THAN AT 1,1.
C
C NOTE THAT N-ARY FUNCTIONS ARE FNAMEARGS,ARGS,...
C AND RANGES ARE CELL1:CELLN. MULTIPLE COMMANDS IN FORMULA ARE
C DELIMITED BY \ CHARACTER.
C
C RETURN CODES:
C IF ICODE=1, COMMAND JUST MOVES ON DISPLAY, SO NO NEED TO RECALCULATE
C THE ENTIRE SHEET.
C ICODE =-1 ==> REINITIALIZE DISPLAY DEFAULTS
C ICODE =2 ==> REDRAW WHOLE SCREEN
C ICODE =-2 ==> NEW SPREAD SHEET FILE SETUP.
C OTHER: ALL OK.
498 CONTINUE
KLVL=1
ICODE=3
C DEFAULT RETURN CODE SAYING ALL WELL
C FIRST DISPLAY CURRENT CELL AGAIN IN NORMAL.
THISRW=DROW
THISCL=DCOL
FORM(1)=0
C GET IN THE CURRENT FORMAT WHEREVER WE ARE, EVEN IF NOT ON DISPLAY SHEET.
C IRRX=(PCOL-1)*60+PROW
CALL REFLEC(PCOL,PROW,IRRX)
CALL WRKFIL(IRRX,FORM2,0)
CALL CE2A(FORM2,FORM)
C READ(7'IRRX)FORM
IF(THISRW.LE.0.OR.THISCL.LE.0)GOTO 200
N1=NRDSP(THISRW,THISCL)
N2=NCDSP(THISRW,THISCL)
IXLSTC=THISCL
IXLSTR=THISRW
IF(THISCL.GT.DCLV.OR.THISRW.GT.DRWV)GOTO 200
C REDRAW LAST DISPLAYED CELL IN NORMAL (I.E., NOT REVERSE) VIDEO.
C IF(ICHAR(FVLD(N1,N2)).EQ.0)GOTO 200
C ONLY REDRAW NUMBERS. DIRECT DISPLAY OR NOTHING GETS IGNORED.
J=8
C IRRX=(N2-1)*60+N1
CALL REFLEC(N2,N1,IRRX)
C ADD 6 COLS FOR LABELS
DO 1 M1=1,DROW
C FIND DISPLAY COLUMN TO USE
1 J=J+CWIDS(M1)
J=J-CWIDS(DROW)
C USE THISCL+1 TO LET 1ST ROW BE LABELS.
ICCC=THISCL+2
C 0 = 1 IF VT100, 0 IF VT52
C SAVE PHYS COORDS BEING DISPLAYED NEXT. FVLD CAN BE TESTED FOR NUMERICS
C DIRECTLY, IF UVT100 NEEDS THAT ACCESS.
IC1POS=N1
IC2POS=N2
IF(PZAP.NE.0)GOTO 3607
CALL UVT100(1,ICCC,J)
C SELECT ROW "THISCL", COL "J"
CALL UVT100(13,7,0)
CALL FVLDGT(N1,N2,FVLD(1,1))
C IF(FVLD(1,1).EQ.0)WRITE(6,5538)
C5538 FORMAT('>-<')
ivv=min0(30,cwids(DROW))
c reset blanks to be sure we write something even for vt52
ccc blanks(1)='>'
IF(ICHAR(FVLD(1,1)).EQ.0)CALL SWRT(BLANKS,IVV)
ccc blanks(1)=32
cccccc no VT52's in PCs...
C5538 FORMAT(1H+,30(a1,'\'))
3607 CONTINUE
C WE CAN BE SURE THE COLUMN IS 3 WIDE OR MORE...
CALL FVLDGT(N1,N2,FVLDTP)
IF(ICHAR(FVLDTP).EQ.0)GOTO 200
C IRRX=(N2-1)*60+N1
C SELECT REVERSE VIDEO
DO 5540 KKKK=1,100
5540 CMDLIN(KKKK)=char(32)
CALL WRKFIL(IRRX,FORM2,0)
CALL CE2A(FORM2,FORM)
d write(*,1094)n1,n2,(form(kkkk),kkkk=1,40)
d1094 format(' Decoded x cell',2i10,'=',40a1)
C READ(7'IRRX)FORM
C IF(JCHAR(FORM(120)).LE.0)GOTO 200
IF(JCHAR(FVLDTP).LT.0.OR.FORMFG.NE.0)
1 WRITE(CMDLNA(1:127),8201)(FORM(II),II=1,100)
8201 FORMAT(128A1)
IF(FORMFG.NE.0)GOTO 4320
DO 6301 KKK=1,9
KKKK=ICHAR(FORM(KKK+119))
C KKKK=DFMTS(KKK,THISRW,THISCL)
6301 DFE(KKK+1)=CHAR(MAX0(32,KKKK))
DFE(11)=CHAR(32)
C 32 = ASCII SPACE
DFE(1)='('
DFE(12)=' '
DFE(13)=' '
DFE(14)=')'
d write(*,1093)dfe
d1093 format(' DFE (xqtcmd) format=',14a1,';')
CALL TYPGET(N1,N2,TYPE(1,1))
IF(TYPE(1,1).EQ.2.AND.JCHAR(FVLDTP).GT.0)
1 WRITE(CMDLNA(1:127),DFE,ERR=4320)DVS(THISRW,THISCL)
IF(TYPE(1,1).NE.2.AND.JCHAR(FVLDTP).GT.0)
1 WRITE(CMDLNA(1:127),DFE,ERR=4320)LDVS(1,THISRW,THISCL)
C REDRAW THIS COL. WITH REVERSE VIDEO HERE.
4320 IF(PZAP.EQ.0)CALL SWRT(CMDLIN,CWIDS(THISRW))
C9800 FORMAT('+',128(A,'\'))
9000 FORMAT(128A1)
IF(PZAP.EQ.0)CALL UVT100(13,0,0)
C NOTE THIS REDRAWS PREVIOUS COL. IN REVERSE VIDEO.
C NO CARRIAGE CTL
200 CONTINUE
IF(PZAP.NE.0)GOTO 3608
KKKK=JCHAR(FVLDTP)
C SKIP LAST LINE UPDATE IF NOT NEEDED FOR SPEEDIER CURSOR
C POSITIONING.
IF(NULAST.EQ.NCEL.AND.LFVD.EQ.0.AND.KKKK.EQ.0)GOTO 222
CALL UVT100(1,LLDSP,1)
CALL UVT100(12,2,0)
IF(JCHAR(FORM(1)).LE.0)GOTO 222
DO 1711 IVVVV=1,109
IVV=110-IVVVV
IF(JCHAR(FORM(IVV)).GT.32)GOTO 2711
1711 CONTINUE
2711 CONTINUE
d write(*,4092)ncel,form(1),form(2),form(3)
d4092 format(' Xqtcmd ncel prt=',i9,' form 1-3=',3a1)
write(fwt(1:127),9092)ncel,(form(ii),ii=1,IVV)
9092 FORMAT(1X,I5,' Used. Curr=',109A1)
IVV=IVV+18
call swrt(fwt(1:127),IVV)
C3608 CONTINUE
222 CALL UVT100(1,LLCMD,1)
NULAST=NCEL
LFVD=KKKK
CALL UVT100(12,2,0)
C NOTE PROW IS ACROSS TOP, PCOL IS DOWN SIDE
C PROW GOES AS ID1, ALPHAS
C PCOL GOES AS ID2, NUMERICS
CALL IN2AS(PROW,FORM)
C NOTE PCOL STARTS AT 2 FOR NORMAL SHEET VARIABLES. PCOL=1 IS FOR ACCUMULATORS
CALL UVT100(13,0,0)
C WRITE OUT LABEL WITH APPROPRIATE SIZE TO HOLD ROW NUMBER
C LET PROMPT END WITH > OR : DEPENDING ON OPERATING MODE.
FVLDTP='>'
IF(MODPUB.EQ.1)FVLDTP=':'
d write(*,4091)prow,pcol,fvldtp
d4091 format(' prow, pcol, mode char=',2i10,4a1)
IF(PCOL.GE.10000)GOTO 6401
ii=pcol-1
write(fwt(1:127),9001,err=3608)
1 (form(i),i=1,4),ii,FVLDTP
C FORM(9)=FVLDTP
III=9
GOTO 6402
6401 CONTINUE
ii=pcol-1
write(fwt(1:127),9401,err=3608)
1 (form(i),i=1,4),ii,FVLDTP
C FORM(10)=FVLDTP
III=10
6402 CONTINUE
CALL SWRT(fwt(1:127),III)
9401 FORMAT(4A1,I5,1A1)
9001 FORMAT(4A1,I4,1A1)
3608 CONTINUE
IF(XTCFG.NE.0)GOTO 3870
Rewind 11
IF(IOLVL.NE.11.or.FH.eq.0)READ(IOLVL,9002,END=510,ERR=510)CMDLIN
C FOR READING THE CONSOLE, WE NEED A QIO$ TO CAPTURE ESCAPE SEQUENCES.
IF(IOLVL.EQ.11.and.FH.ne.0)CALL GETTTL(CMDLIN)
CALL GTMUNG(CMDLIN)
C ALLOW CMD LANGUAGE TO LOOK MORE "STANDARD" VIA MUNGE OF INPUTS
C TO DO THE "EV" OR "ET" OR "EN" FOR USER AND TREAT / AS CMD
C PREFIX...
GOTO 3871
3870 CONTINUE
XTCFG=0
DO 3872 I=1,XTNCNT
CMDLIN(I)=XTNCMD(I)
3872 CONTINUE
C COPY IN EXTERNAL COMMAND AND LET IT BE EXECUTED. IT'S THE USER'S
C PROBLEM IF THE COMMAND REQUIRES STILL FURTHER INPUT...
C ALSO NULL OUT SOME DELIMITER CHARS AFTER THE COMMAND READ IN.
CMDLIN(XTNCNT+1)=Char(0)
CMDLIN(XTNCNT+2)=Char(0)
3871 CONTINUE
9002 FORMAT(64A1,64A1,32A1)
CMDLIN(132)=Char(0)
CMDLIN(131)=Char(0)
CMDLIN(130)=Char(0)
C SAVE CURRENT PHYS ROW, COL IN AC'S X AND Y
XXAC=PROW
XYAC=PCOL
C ZAP IN SPECIAL FUNCTION KEY REPLIES INTO NORMAL FORMS
CALL CMDMUN(CMDLIN)
DO 9048 I=1,129
K=130-I
C START AT BACK OF LINE AND ZAP WHITESPACE BY NULL TERMINATOR
IF(ICHAR(CMDLIN(K)).GT.32)GOTO 9049
CMDLIN(K)=Char(0)
C ALSO GET RID OF POSSIBLE TRAILING CR, LF.
9048 CONTINUE
9049 CONTINUE
C
C THIS GETS COMMAND LINE IN. NOW ACTON IT.
C REPOS'N TO OLD LINE NOW.
CALL UVT100(1,LLCMD,1)
C
C THE FOLLOWING SECTION IMPLEMENTS THE ADDITIONAL FUNCTION OF
C JOURNALING: (DONE ON VAX ONLY SINCE SPACE REQUIREMENTS FOR FILE
C OPERATIONS MAY BE A PROBLEM ON PDP11'S).
C Command +J FILENAME will record all remaining
C line inputs at this point in it. (Assumes JNLFLG=0 initially)
C Command +N closes journal file.
K=K+1
IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'J'.AND.JNLFLG.NE.1)
1 GOTO 4290
IF(CMDLIN(1).EQ.'+'.AND.CMDLIN(2).EQ.'N')GOTO 4292
IF(JNLFLG.EQ.1)WRITE(10,9002)(CMDLIN(IV),IV=1,K)
GOTO 4291
4292 CONTINUE
CLOSE(10)
JNLFLG=0
GOTO 9990
4290 CONTINUE
JNLFLG=1
C USE WHATEVER FILE NAME THE USER HAS SUPPLIED AFTER THE +J
C FOR FILE TO JOURNAL ONTO. (NO MORE QUESTIONS NEEDED.)
CALL WASSIG(10,CMDLIN(4))
GOTO 9990
4291 CONTINUE
C
C
C ALLOW COMMENTS IF LINE BEGINS WITH * (JUST LIKE CALC)
IF(CMDLIN(1).NE.'*')GOTO 6002
ICODE=1
C NO RECALC JUST FOR COMMENTS...
GOTO 9990
6002 CONTINUE
C
C * NEW ****************
C ADD PLACE TO PUT IN USER COMMANDS. DEFAULT IS NONE EXIST, DO NOTHING
IGOTIT=0
CALL USRCMD(CMDLIN,ICODE,IGOTIT)
C WHEN WE GET A COMMAND, SET IGOTIT TO 1 AND WE THEN PROCESS COMMAND NORMALLY
IF(IGOTIT.EQ.1)GOTO 9990
C * NEW ****************
C
C COMMAND -PROMPT WILL READ FROM LUN 5 TO ARGSTR
C TERMINATING WITH SPACES.
IF(CMDLIN(1).NE.'-')GOTO 350
ICODE=5
CALL UVT100(1,LLCMD,1)
CALL UVT100(12,2,0)
CALL VWRT(CMDLIN(2),49)
C WRITE(0,9800)(CMDLIN(IV),IV=2,50)
READ(11,9000,END=510,ERR=510)FORM2
II=1
KK=1
DO 351 KKK=1,128
C LOAD UP OUR ARGUMENTS IN ARGSTR(N,1) TO ARGSTR(N,4)
ARGSTR(KK,II)=FORM2(KKK)
KK=KK+1
ARGSTR(KK,II)=0
IF(KK.LT.52)GOTO 352
354 KK=1
II=II+1
IF(II.GT.4)GOTO 353
352 CONTINUE
IF(ICHAR(FORM2(KKK)).GT.32)GOTO 351
C ON SPACE, GO TO THE NEXT ARGUMENT. ALSO SPILL INTO
C THE NEXT ARGUMENT IF WE SEE NO SPACES AND JUST TRAIL ALONG.
GOTO 354
351 CONTINUE
353 GOTO 9990
350 CONTINUE
C
C CONTROL SCROLLING. PERMIT THE COMMAND "SC" TO TURN SCROLLING ON
C AND "NS" TO TURN IT BACK OFF.
IVV=-1
IF(CMDLIN(1).EQ.'S'.AND.CMDLIN(2).EQ.'C')IVV=1
IF(CMDLIN(1).EQ.'N'.AND.CMDLIN(2).EQ.'S')IVV=0
IF(IVV.GE.0)IDOL7=IVV
IF(IVV.GE.0)ICODE=5
IF(IVV.GE.0)GOTO 9990
C
C ALLOW PROGRAMMED "REWIND" OF INPUT COMMAND LINE ON
C COMMAND LINE BEGINNING WITH "<". MAKE IT CONDITIONAL
C BY SAYING THAT IF % IS NEGATIVE WE WON'T DO IT.
IF(CMDLIN(1).NE.'<')GOTO 356
ICODE=5
IF(XAC.GT.0..AND.IOLVL.NE.11)REWIND IOLVL
GOTO 9990
356 CONTINUE
C
C HANDLE @FILE COMAND TO CHANGE TO INPUT OFF THAT FILE.
IF(CMDLIN(1).NE.'@')GOTO 511
C WOW, A FILE. (OR AT LEAST SO WE HOPE).
CALL RASSIG(3,CMDLIN(2))
C USE FACT THAT WE JUST NULL TERMINATED THE FILENAME PART AND SET
C IT TO BE LUN 3.
IOLVL=3
C NOW GO BACK FOR ANOTHER COMMAND...NO SENSE WASTING RECALC TIME SINCE
C NOTHING HAS REALLY HAPPENED YET.
C NOTE EVERY READ TO LUN 3 HAS EOF/ERROR CHECK TO GO TO 510 TO RESET
C TO LUN 5 INPUT AND CLOSE FILE WE OPENED ON 3.
GOTO 498
511 CONTINUE
C
C AA n R, AA n C, AR n R, AR n C COMMANDS
C
IF(CMDLIN(1).NE.'O'.OR.CMDLIN(2).NE.'V')GOTO 6887
C OV + TURNS ON OVERRIDE
C OV - TURNS OFF OVERRIDE
C ALLOWS ONE TO OVERRIDE $ SIGN FORMS' ABSOLUTE NATURE
IF(CMDLIN(3).EQ.'+'.OR.CMDLIN(4).EQ.'+')IDOL3=1
IF(CMDLIN(3).EQ.'-'.OR.CMDLIN(4).EQ.'-')IDOL3=0
GOTO 9990
6887 CONTINUE
IF(CMDLIN(1).NE.'A')GOTO 8845
C ADD ROWS OR COLUMNS (OR REMOVE THEM) AT THE CURRENT PHYSICAL LOCATION
C WHERE AA MEANS ADD ABSOLUTE (NO RELOCATION), AR MEANS ADD RELOCATING
C (RELOCATE ALL VARIABLES BELOW), AND R OR C SAYS TO ADD/SEBTRACT ROWS
C OR COLUMNS.
C
C FIRST COLLECT THE ARGUMENTS TO THE FUNCTION.
KM1=3
KM2=10
CALL GN(KM1,KM2,ICNT,CMDLIN)
C GETS THE NUMBER. IF NO NUMBER SEEN OR ZERO, RETURNS 0. IGNORE THEN.
IF(ICNT.EQ.0)GOTO 9990
ICR=0
C LOOK FOR THE R OR C
C START AT CMDLIN(4) TO PASS THE AR/AA AND THE NUMBER IF ANY.
DO 8844 KKK=4,50
IF(CMDLIN(KKK).EQ.'R')ICR=1
IF(CMDLIN(KKK).EQ.'C')ICR=2
IF(ICR.NE.0)GOTO 8846
C SKIP OUT ON FIRST ROW OR COLUMN DESIGNATOR SEEN
8844 CONTINUE
8846 CONTINUE
IF(ICR.EQ.0)GOTO 9990
ICODE=2
C NOW WE HAVE ALL ARGUMENTS. SET UP FOR THE COPY AND PARASITE THE
C LOGIC USED FOR THE CA OR CR COMMANDS. (NOTE THAT 2ND CHARACTER
C IS A OR R IN CMDLIN ALREADY SO THOSE COMMANDS' LOGIC WILL BE OK.)
JRTR=PROW
JRTC=PCOL
IF(ICR.EQ.2)JRTC=1
IF(ICR.EQ.1)JRTR=1
C RELOC THESHOLD IS PHYSICAL CURRENT POSITION.
IF(ICR.EQ.1)GOTO 8843
C INSERT OR DELETE COLUMNS
C FIRST FIGURE OUT HOW MANY COLUMNS MUST BE MOVED RIGHT
KD=60-PROW-IABS(ICNT)+1
C LET THIS WORK ONLY ON PRIME SHEET. TOO HARD TO FIGURE IT OUT ON REFLECTED
C ONES AND IT'LL FOUL LOTS OF USERS UP.
IF(KD.LE.0)GOTO 9990
C CAN'T MOVE 0 COLUMNS. DOESN'T MAKE SENSE.
DO 8842 KR=1,KD
IRA=60-KR+1
C IRA IS DESTINATION COLUMN IN EACH LOOP.
IF(ICNT.LT.0)IRA=PROW-1+KR
C IRS IS SOURCE COLUMN
IRS=60-KR+1-ICNT
IF(ICNT.LT.0)IRS=PROW+KR-ICNT-1
C
C IF DELETING COLUMNS AND DESTINATION IS PAST CURRENT
C ACTIVE MAX, SKIP THE MOVE SINCE WE'RE NOT ACCOMPLISHING ANYTHING.
IF(ICNT.LT.0.AND.IRA.GT.RRWACT)GOTO 8842
C IF ADDING COLUMNS AND SOURCE IS PAST CURRENT MAX ACTIVE THEN
C WE'RE DOING NOTHING, SO SKIP THE WORK
IF(ICNT.GT.0.AND.IRS.GT.RRWACT)GOTO 8842
JDELT=RCLACT
C JDELT=301
C LOOP WE'LL CALL IS OVER ENTIRE ROWS, BUT ONLY DO ONE AT A TIME HERE
JD1A=IRA
JD1B=1
ID1A=IRS
ID2A=1
I1IN=0
I2IN=1
JIN1=0
JIN2=1
ASSIGN 8840 TO KPYBAK
C CALL INTERNAL COPY-RANGE PROCEDURE INSIDE CA/CR LOGIC
GOTO 8364
8840 CONTINUE
8842 CONTINUE
C
C NOW CLEAN UP THE REST OF FORMULAS IF THERE ARE ANY TO DO...
C MUST RELOCATE OTHER FORMULAE IF CMDLIN(2) IS R
KX=PROW-1
C RELY ON RCLACT HAVING BEEN UPDATED TO REFLECT NEW
C ADDITIONS IF ANY
KY=RCLACT
C KY=301
C RELOCATE UPPER LEFT PART OF SHEET
C NOTE II1,II2,JJ1,JJ2,JRTR,JRTC ARE UNCHANGED FROM PRIOR CALL SO
C MAY BE USED... RELVBL ONLY CARES ABOUT RELATIVE MOTION ANYHOW...
3600 CONTINUE
IF(CMDLIN(2).NE.'R'.OR.KX.LE.0.OR.KY.LE.0)GOTO 9990
DO 3601 KK=1,KX
DO 3601 KK2=1,KY
CALL FVLDGT(KK,KK2,FVLD(1,1))
IF(ICHAR(FVLD(1,1)).NE.1)GOTO 3601
C ONLY RELOCATE FORMULAS, NOT TEXT OR NUMBERS (OR EMPTIES...)
C IRX=(KK2-1)*60+KK
CALL REFLEC(KK2,KK,IRX)
CALL WRKFIL(IRX,FORM,0)
C READ(7'IRX)FORM
CALL RELVBL(FORM,FORM2,II1,II2,JJ1,JJ2,JRTR,JRTC)
CALL WRKFIL(IRX,FORM2,1)
C WRITE(7'IRX)FORM2
3601 CONTINUE
GOTO 9990
8843 CONTINUE
C ROW INSERT/DELETE
C AGAIN FIND HOW MANY ROWS TO MOVE.
KD=301-PCOL-IABS(ICNT)+1
IF(KD.LE.0)GOTO 9990
DO 8839 KC=1,KD
C ICA = DESTINATION AND ICS IS SOURCE
ICA=301-KC+1
ICS=301-KC+1-ICNT
IF(ICNT.GT.0)GOTO 8838
ICA=PCOL-1+KC
ICS=PCOL+KC-1-ICNT
8838 CONTINUE
C IF INSERTING ROWS AND SRC ROW IS BEYOND ACTIVE AREA, SKIP
IF(ICNT.GT.0.AND.ICS.GT.RCLACT)GOTO 8839
C IF DELETING ROWS AND DST ROW IS BEYOND ACTIVE AREA, SKIP
IF(ICNT.LT.0.AND.ICA.GT.RCLACT)GOTO 8839
C NOW CALL COPY LOOP AGAIN.
JDELT=RRWACT
C JDELT=60
JD1A=1
JD1B=ICA
C DEST
ID1A=1
ID2A=ICS
C SOURCE
I1IN=1
I2IN=0
JIN1=1
JIN2=0
ASSIGN 8836 TO KPYBAK
C CALL INTERNAL RANGE COPY PROCEDURE TO COPY A ROW
GOTO 8364
8836 CONTINUE
8839 CONTINUE
KX=RRWACT
C KX=60
KY=PCOL-1
GOTO 3600
8845 CONTINUE
C OA AND OR COMMANDS. SET DISPLAY SHEET MAPPING TO ORIGIN AS FOUND BY
C VARIABLE, STARTING AT 1,1 OR (DROW,DCOL) FOR OA AND OR RESPECTIVELY.
IF(CMDLIN(1).NE.'O')GOTO 650
C PROCESS COMMAND...
LRO=1
LCO=1
IF(CMDLIN(2).EQ.'R')LRO=MAX0(1,DROW)
IF(CMDLIN(2).EQ.'R')LCO=MAX0(1,DCOL)
LRO=MIN0(LRO,19)
LCO=MIN0(LCO,74)
C LRO=MIN0(LRO,(20-1))
C LCO=MIN0(LCO,(75-1))
C NOW HAVE CORRECT ORIGIN IN DISPLAY SHEET TO USE SET UP.
C GRAB VARIABLE ID.
LA=INDX(CMDLIN,32)
IF(LA.GT.20)LA=3
LE=40
CALL VARSCN(CMDLIN,LA,LE,LSTCX,ID1,ID2,IVLD)
IF(IVLD.EQ.0)GOTO 651
C NOW HAVE VARIABLE NAME AND LOCATION... CAN DO IT FINALLY.
C NOTE WE'RE GUARANTEED WE START OFF IN BOUNDS BUT MUST CHECK
C ALONG THE WAY TO BE SURE WE STAY THAT WAY.
IQQ=0
KKKK=0
IF(CMDLIN(3).NE.'D')GOTO 6712
c allow ORA or ORD commands to leave window displacements
c alone. Fix up so this is default mode for scrolling (making
c program behavior easier to understand.)
7112 CONTINUE
KKKK=1
6712 CONTINUE
KKKKK=NRDSP(LRO,LCO)
KKKKKK=NCDSP(LRO,LCO)
5711 CONTINUE
C TO ALLOW REFLECTIONS MUST ALLOW ALL SORTS OF ORIGINS.
DO 652 IRO=LRO,DRWV
DO 653 ICO=LCO,DCLV
C HERE CAN SET UP NRDSP AND NCDSP SUITABLY
IVV=IRO-LRO
IVVV=ICO-LCO
IF(KKKK.EQ.0)GOTO 1653
IVV=NRDSP(IRO,ICO)-KKKKK
IVVV=NCDSP(IRO,ICO)-KKKKKK
1653 CONTINUE
NRDSP(IRO,ICO)=ID1+IVV
NCDSP(IRO,ICO)=ID2+IVVV
653 CONTINUE
652 CONTINUE
IF(DROW.LE.0.OR.DCOL.LE.0)GOTO 3924
PROW=NRDSP(DROW,DCOL)
PCOL=NCDSP(DROW,DCOL)
3924 CONTINUE
C FORCE REDRAW OF WHOLE SHEET.
ICODE=6
IF(RCMODE.LE.0)GOTO 9990
C SKIP RECALC IF IN OLD MODE...
ICODE=2
651 GOTO 9990
650 CONTINUE
C F FILENAME/NNN
C READ IN TEXT FROM FILE NAMED AND SPREAD ACROSS DISPLAY SCREEN. SET
C DISPLAYED SCREEN INTO FVLD(NN)=-1 TO SHOW TEXT ONLY.
IF(CMDLIN(1).NE.'F')GOTO 1740
LA=INDX(CMDLIN,32)
C PASS SPACE
KKK=ICHAR('/')
LB=INDX(CMDLIN(LA+1),KKK)
LB=LB+LA
C LB= LOC OF / CHARACTER
LB=MIN0(80,LB)
IF(LB.LE.2)GOTO 1741
IF((LB-LA).LE.1) GOTO 1741
CMDLIN(LB)=0
CALL RASSIG(4,CMDLIN(LA+1))
C THIS OUGHT TO OPEN THE FILE IF IT EXISTS..
C NOW IF THERE'S A NUMBER THERE, EXTRACT IT.
LSKP=0
IF(LB.GT.78.OR.LB.LE.5)GOTO 1743
LAA=LB+1
LAAA=LB+7
CALL GN(LAA,LAAA,LSKP,CMDLIN)
1743 CONTINUE
C NOW SKIP THE LINES
IF(LSKP.LE.0)GOTO 1744
DO 1745 IV=1,LSKP
READ(4,8201,END=1742,ERR=1742)FORM2
1745 CONTINUE
1744 CONTINUE
C NOW WE'RE READY TO READ IN THE STUFF.
ICODE=2
DO 1746 LA=1,DCLV
DO 1751 IV=1,128
1751 FORM2(IV)=Char(32)
READ(4,8201,END=1742,ERR=1742)FORM2
IXC=0
DO 1747 LB=1,DRWV
C DRWV = # ACROSS TOP...
C DCLV=LENGTH
ID1=NRDSP(LB,LA)
ID2=NCDSP(LB,LA)
C GET PHYSICAL SHEET COORDINATES AS ID1,ID2
C MUST THEN COPY CWIDS(LB) CHARS ONTO FILE...
CALL FVLDST(ID1,ID2,char(255))
C FVLD(ID1,ID2)=-1
C IRX=(ID2-1)*60+ID1
CALL REFLEC(ID2,ID1,IRX)
CALL WRKFIL(IRX,FORM,0)
C READ(7'IRX)FORM
FORM(119)=Char(255)
DO 1749 IVV=1,110
1749 FORM(IVV)=0
DO 1748 IVV=1,CWIDS(LB)
IXC=IXC+1
1748 FORM(IVV)=FORM2(IXC)
CALL WRKFIL(IRX,FORM,1)
1747 CONTINUE
1746 CONTINUE
1742 CLOSE(4)
1741 GOTO 9990
1740 CONTINUE
IF(CMDLIN(1).NE.'E')GOTO 8000
C ENTER COMMAND
C EN expression. expression may be numbers/text.
LA=INDX(CMDLIN,32)
LA=LA+1
C SKIP SPACE AFTER "EN"
IF(LA.GT.4)LA=4
IF (LA.GE.100)GOTO 7901
LE=132-LA
LE=MIN0(110,LE)
C IRX=(PCOL-1)*60+PROW
CALL REFLEC(PCOL,PROW,IRX)
C FIND WHERE IN FILE TO STORE.
CALL WRKFIL(IRX,FORM2,0)
CALL CE2A(FORM2,FORM)
C READ(7'IRX)FORM
IF(CMDLIN(2).EQ.'D')
1 CALL SED(CMDLIN(LA),FORM,FORM2,ARGSTR,ZAC,110)
C IF COMMAND IS "ED <DELIM>STRING1<DELIM>STRING2<DELIM>" THEN
C SUBSTITUTE STRING2 FOR STRING1 IN FORMULA, RETURN IT TO THE
C COMMAND LINE, AND REENTER IT.
C NOTE THAT THE STRINGS MAY CONTAIN &n FORMS WHERE 1-4 MEAN
C ENTERED ARGUMENTS 1-4, 5 TREATS XAC AS A NUMBER, AND 6
C TREATS ZAC AS A SINGLE CHARACTER (ZAC IS VARIABLE Z).
DO 5133 II=1,110
5133 FORM(II)=0
NALF=0
NSG=-1
NXNUM=3
KSG=0
N=1
IRCE1=PROW
IRCE2=PCOL
C SAVE FOR RE, RI MODES
IF(CMDLIN(2).EQ.'T'.OR.CMDLIN(2).EQ.'"')KSG=1
C "ET" FORMULA ENTERS TEXT ONLY
C "EV" FORMULA ENTERS NUMBER
IF(CMDLIN(2).EQ.'V')NSG=1
2097 CONTINUE
IF(N.GT.LE)GOTO 7902
C DO 7902 N=1,LE
C LOOK FOR ALPHAS. IF WE FIND ANY, FLAG NOT NUMERIC
C NOTE @ INCLUDED SINCE COULD HAVE A *@3 COMMAND TO CALL 3.CMD
C AND REFER TO OTHER CELLS.
C THIS IS A RESTRICTION: COMMANDS TO CMND NEED TO HAVE ALPHAS
C SOMEWHERE OR THIS WILL BE FOOLED.
IF(CMDLIN(LA).EQ.'P'.AND.
1 CMDLIN(LA+1).EQ.'#'.AND.
2 CMDLIN(LA+2).EQ.'0'.AND.
3 CMDLIN(LA+3).EQ.'#'.AND.
4 CMDLIN(LA+4).EQ.'0') GOTO 3356
IF(ICHAR(CMDLIN(LA)).GE.ICHAR('@').AND.ICHAR(CMDLIN(LA))
1 .LE.ICHAR('Z'))NXNUM=1
3356 CONTINUE
IF(CMDLIN(LA).EQ.'+'.OR.CMDLIN(LA).EQ.'-')NSG=1
IF(CMDLIN(LA).EQ.'['.OR.CMDLIN(LA).EQ.'.')NSG=1
IF(CMDLIN(LA).EQ.'(')NSG=1
IF(CMDLIN(LA).EQ.'"')KSG=1
C ON SEEING THE _@V1,V2 CONSTRUCT, REPLACE WITH THE VARIABLE
C ADDRESSED BY V1,V2 (COL,ROW) BY NAME.
C ON SEEING THE _#V1 CONSTRUCT, UNPACK UP TO 8 CHARS OUT OF
C REAL*8 VARIABLE (PACKED BY MULTIPLYING BY 128 EARLIER).
C IN EACH CASE, ADJUSTN AND LE TO CONTINUE APPROPRIATELY.
IF(CMDLIN(LA).EQ.'_'.AND.CMDLIN(LA+1).EQ.'@')CALL
1 SVBL(CMDLIN,LA,N,LE,FORM)
IF(CMDLIN(LA).EQ.'_'.AND.CMDLIN(LA+1).EQ.'#')CALL
1 SSTR(CMDLIN,LA,N,LE,FORM)
FORM(N)=CMDLIN(LA)
IF(ICHAR(CMDLIN(LA)).GT.32)NALF=NALF+1
LA=LA+1
C FAKE OUT DO LOOP SINCE SVBL OR SSTR MAY MUNG INDICES INSIDE IT
N=N+1
GOTO 2097
7902 CONTINUE
IF(KSG.NE.0)NSG=-1
FORM(110)=0
IF(ICHAR(FORM(119)).NE.0)GOTO 7903
C LEAVE DISPLAY INDICATOR ALONE IF SET BUT SET VBL OTHERWISE.
IVVVV=NSG*NXNUM
FORM(119)=CHAR(IVVVV)
C SET NEG FOR DISPLAY OF FORMULA, NOT NUMBER. ALLOWS TEXT ENTRY.
C ASSUME FORMULA IF WE SEE + OR -
7903 CONTINUE
C FORCE FORM TO FOLLOW EDITS EVEN IF FORMAT/TYPE PRESET.
IVVVV=JCHAR(FORM(119))
IF(IVVVV.NE.0)FORM(119)=CHAR(ISGN(IVVVV)*NXNUM)
IF(NALF.LE.0)GOTO 6221
CALL FVLDST(PROW,PCOL,FORM(119))
C ENCODE CELL NAMES PRIOR TO STORING
CALL CA2E(FORM,FORM2)
CALL WRKFIL(IRX,FORM2,1)
6221 CONTINUE
ASSIGN 7904 TO NBK
GOTO 7905
C LOOK UP PROW, PCOL, LEAVE DISPLAY COORDS IN LR,LC
7905 CONTINUE
DO 7906 LA1=1,DRWV
LR=LA1
DO 7906 LA2=1,DCLV
LC=LA2
IF(NRDSP(LA1,LA2).EQ.PROW.AND.NCDSP(LA1,LA2).EQ.PCOL)GOTO7907
7906 CONTINUE
C IF WE FALL OUT OF THE LOOP, WE DIDN'T FIND THE LOC; FLAG BY PUTTING 0'S.
LR=0
LC=0
GOTO 7908
7907 CONTINUE
C ARRIVE HERE ON SUCCESS. LR, LC ALL SET UP.
7908 CONTINUE
GOTO NBK,(7904,8901,8957)
7904 CONTINUE
IF(LR.EQ.0.OR.LC.EQ.0)GOTO 7901
THISRW=LR
THISCL=LC
C ASCII 1,2,3,4 ARE VALUES 49,50,51,52 IN DECIMAL.
LRO=1
LCO=1
ID1=NRDSP(1,1)
ID2=NCDSP(1,1)
IF(.NOT.(JMVFG.EQ.51.AND.THISRW.EQ.1))GOTO 7110
C MUST SCROLL LEFT
IF(IDOL7.EQ.0)GOTO 7110
IF(ID1.LE.1)GOTO 7110
ID1=MAX0(1,ID1-DRWV+2)
DROW=MAX0(1,DRWV-2)
IQQ=1
GOTO 7112
7110 CONTINUE
IF(JMVFG.EQ.51)THISRW=MAX0(1,(THISRW-1))
IF(.NOT.(JMVFG.EQ.52.AND.THISRW.EQ.DRWV))GOTO 7116
C MUST SCROLL RIGHT
IF(IDOL7.EQ.0)GOTO 7116
DROW=3
C ID1=MIN0(60,ID1+DRWV-MIN0(DRWV,2))
ID1=ID1+DRWV-MIN0(DRWV,2)
IQQ=1
GOTO 7112
C 7112 FAKES OUT OA CALL TO SCROLL OVER.
7116 CONTINUE
IF(JMVFG.EQ.52)THISRW=MIN0((THISRW+1),DRWV)
IF(.NOT.(JMVFG.EQ.49.AND.THISCL.EQ.1))GOTO 7117
C MUST SCROLL UP
IF(IDOL7.EQ.0)GOTO 7117
IF(ID2.LE.2)GOTO 7117
DCOL=MAX0(1,DCLV-2)
ID2=MAX0(2,ID2-DCLV+2)
IQQ=1
GOTO 7112
7117 CONTINUE
IF(JMVFG.EQ.49)THISCL=MAX0(1,(THISCL-1))
IF(.NOT.(JMVFG.EQ.50.AND.THISCL.EQ.DCLV))GOTO 7118
C MUST SCROLL DOWN
IF(IDOL7.EQ.0)GOTO 7118
DCOL=3
C ID2=MIN0(301,ID2+DCLV-MIN0(DCLV,2))
ID2=ID2+DCLV-MIN0(DCLV,2)
IQQ=1
GOTO 7112
7118 CONTINUE
IF(JMVFG.EQ.50)THISCL=MIN0((THISCL+1),DCLV)
DROW=THISRW
DCOL=THISCL
PROW=NRDSP(DROW,DCOL)
PCOL=NCDSP(DROW,DCOL)
C FORCE REDO OF BOTH LAST AND NEW COLUMN BY DISPLAYER.
DVS(LR,LC)=DVS(LR,LC)+.0000000057
DVS(DROW,DCOL)=DVS(DROW,DCOL)+.000000062
7901 GOTO 9990
8000 IF(CMDLIN(1).NE.'M')GOTO 8001
ICODE=1
C MACROCELL COMMAND IF MH (HIDE) OR MS (SHOW)
IF(CMDLIN(2).EQ.'S')IDOL4=1
IF(CMDLIN(2).EQ.'H')IDOL4=0
IF(CMDLIN(2).EQ.'S'.OR.CMDLIN(2).EQ.'H')GOTO 9990
C MOVE COMMAND
C M1,M2,M3,M4 MOTION DIRECTION IS U,D,L,R
IVVV=ICHAR(CMDLIN(2))
C ALLOW M0 TO MEAN RESTORE PRIOR STATE OF AUTOMOVE AND
C SAVE CURRENT STATE AS NEW PRIOR ONE. M1 THRU M5 MEAN SET
C AUTOMOVE TO 1-5 (5=NO MOTION) AND SAVE OLD STATE AS LAST
C STATE.
IF(CMDLIN(2).EQ.'0')IVVV=JMVOLD
JMVOLD=JMVFG
JMVFG=IVVV
C JMVFG=ICHAR(CMDLIN(2))
C STORE CHARACTER AS MOVE FLAG
GOTO 9990
8001 IF(CMDLIN(1).NE.'D')GOTO 8002
C DISPLAY COMMANDS
C
C DISPLAY SORT
C DSRA 1
C DS = CONSTANT KEYWORD
C R/C=ROW/COL (DISPLAY COORD #S)
C A/D=ASCENDING/DESCENDING ORDER
C NUMBER= DISPLAY COORD ROW/COL # TO SORT ON.
C SORTS NUMERIC FIELDS ONLY.
IF(CMDLIN(2).NE.'S')GOTO 1752
ICODE=2
C MUST REDRAW. WE DO WHOLESALE RELOCATIONS OF THINGS HERE.
C FIRST GET ARGUMENTS
LAA=6
LBB=15
CALL GN(LAA,LBB,NBR,CMDLIN)
C THIS EXTRACTS THE NUMBER OF ROW/COL TO USE.
C DEFAULT IS PHYS, COL, ASCENDING
C IF(NBR.LE.0.OR.NBR.GT.MAX0(20,75))GOTO 9990
IF(NBR.LE.0.OR.NBR.GT.75)GOTO 9990
SSIGN=1.
IF(CMDLIN(4).EQ.'D')SSIGN=-1.
C SSIGN USED TO CONTROL ASCENDING/DESCENDING SORT (MULTIPLY BY IT)
C GET LENGTH TO GO THRU IN SORT
IF(CMDLIN(3).EQ.'C')IDELTA=DCLV-1
IF(CMDLIN(3).EQ.'R')IDELTA=DRWV-1
I1IN=0
I2IN=1
C GET PHYSICAL COORDINATES OF ROW/COL WE'RE SORTING ON.
IF(CMDLIN(3).EQ.'R')GOTO 6222
ID1=NRDSP(NBR,1)
ID2=NCDSP(NBR,1)
GOTO 1753
6222 CONTINUE
ID1=NRDSP(1,NBR)
ID2=NCDSP(1,NBR)
I1IN=1
I2IN=0
C HACK TO HANDLE ROW/COL ALIKE
1753 CONTINUE
IFLIP=0
C IFLIP = BUBBLESORT FLAG WE CHANGED SOMETHING
C (USE SIMPLE MINDED SMALL SORT. TOO MUCH OVHD FOR BETTER ONE...NO ROOM)
ID1A=ID1
ID2A=ID2
C IGNORE CASE OF IDELTA=0... SHOULDN'T BE ANY WAY FOR THAT TO HAPPEN
DO 1754 IV=1,IDELTA
C SORT HERE. IFLIP=1 IF WE INVERT ANYTHING.
C JUST COMPARE XVBLS...
C NOTE WE ASSUME A "NORMAL" TYPE DISPLAY, JUST RESET PHYSICAL STUFF.
CALL XVBLGT(ID1A,ID2A,XAC)
CALL XVBLGT(ID1A+I1IN,ID2A+I2IN,XVBLS(1,1))
IF(XAC*SSIGN.LE.XVBLS(1,1)*SSIGN)GOTO 1755
C FLIP ASSIGNMENTS
C FLIP XVBLS NUMBERS TOO TO MAINTAIN SORT. WE RECOMPUTE ANYWAY..
CALL XVBLST(ID1A+I1IN,ID2A+I2IN,XAC)
CALL XVBLST(ID1A,ID2A,XVBLS(1,1))
IFLIP=1
C SWAP ASSIGNMENTS OF DISPLAY STUFF IF IN RANGE
C OPERATES LIKE A SORTED OA COMMAND
C CURRENT PHYSICAL ROW IS ID2A (1...RCL LIMITS)
C AND PHYS COL IS ID1A.
C LDELTA=DRW-1
LDELTA=19
C FOR REASSIGNMENT, ROLE OF I1IN,I2IN CAN BE REVERSED...
ID1B=1
C NOTE DISPLAY ID2 IS 1 LESS THAN PHYSICAL ONE. (AC'S)
ID2B=ID2A-1
IF(ID2B.LE.0)GOTO 1754
IF(CMDLIN(3).NE.'R')GOTO 1756
C ROW...
C LDELTA=DCL-1
LDELTA=74
C ID1 SAME AS DISPLAY COORDS
ID1B=ID1A
ID2B=1
1756 CONTINUE
DO 1757 IVV=1,LDELTA
C FLIP THE ROW/COL 1 ENTRY AT A TIME. JUST CHANGES ASSIGNMENTS.
JD1=NRDSP(ID1B,ID2B)
JD2=NCDSP(ID1B,ID2B)
NRDSP(ID1B,ID2B)=NRDSP(ID1B+I1IN,ID2B+I2IN)
NCDSP(ID1B,ID2B)=NCDSP(ID1B+I1IN,ID2B+I2IN)
NRDSP(ID1B+I1IN,ID2B+I2IN)=JD1
NCDSP(ID1B+I1IN,ID2B+I2IN)=JD2
ID1B=ID1B+I2IN
ID2B=ID2B+I1IN
1757 CONTINUE
C WE CAN ALWAYS FLIP SINCE WE STAY ON DISPLAY SHEET.
1755 CONTINUE
ID1A=ID1A+I1IN
ID2A=ID2A+I2IN
1754 CONTINUE
C DONE 1 PASS. IF ANYTHING CHANGED, TRY AGAIN.
IF(IFLIP.NE.0)GOTO 1753
C DONE SORT AT END
GOTO 9990
1752 CONTINUE
C
IF(CMDLIN(2).NE.'L')GOTO 8101
C DL = DISPLAY LOCATE V1:V2 N:M
ASSIGN 8103 TO IBACK
GOTO 8104
C STRIP VARIABLE NAMES OFF CMD LINE STARTING AT POSITION 3
8104 LA=3
LE=98
L1=0
CALL VARSCN(CMDLIN(1),LA,LE,LSTC,ID1A,ID2A,IVLD)
L2=0
C L1,L2 = FLAGS VARIABLE 1,2 FOUND VALIDLY
LA=LSTC+1
LE=100-LA
IF(LE.LE.0.OR.IVLD.LE.0)GOTO 8102
L1=1
IF(CMDLIN(LSTC).NE.':')GOTO 8102
C MUST SEE : BETWEEN NAMES. NO SPACES PERMITTED.
CALL VARSCN(CMDLIN,LA,LE,LSTC,ID1B,ID2B,IVLD)
IF(IVLD.LE.0)GOTO 8102
L2=1
8102 CONTINUE
C NOTE THAT LSTC RETURNS AS CHARACTER AFTER VARIABLE LAST GRABBED IN INPUT LINE.
GOTO IBACK,(8103,8112,8121,8301,8953)
C NOW PICK UP RN:M OR CN:M (R=ROW,C=COL)
8103 CONTINUE
IF(L1.LT.1)GOTO 8101
C INVALID UNLESS AT LEAST 1 VBL NAME SEEN.
LA=LSTC+2
RCF=0
IF(CMDLIN(LSTC+1).EQ.'R')RCF=2
IF(CMDLIN(LSTC+1).EQ.'C')RCF=1
IF(RCF.EQ.0)GOTO 8101
KM1=1
CALL GN(KM1,LE,NUM1,CMDLIN(LA))
IF(NUM1.EQ.0)GOTO 8101
KKK=ICHAR(':')
LE=INDX(CMDLIN(LA),KKK)
NUM2=0
IF(LE.GT.100)GOTO 8101
LA=LA+LE
KM1=1
KM8=8
CALL GN(KM1,KM8,NUM2,CMDLIN(LA))
C NOW NUM1,NUM2 ARE DESIRED ROW/COL RANGE. NOW SET UP DISPLAY.
IF(NUM2.EQ.0.OR.NUM2.GT.75)GOTO 8101
IF(NUM1.GT.20)GOTO 8101
C ILLEGAL ROW/COL IS A NO-GO.
C R N:M MEANS STARTING AT COL N ROW M GOING L TO R.
C C N:M MEANS DOWN STARTING THERE. DISPLAY COORDS ASSUMED.
IF(ID1A.NE.ID1B.AND.ID2A.NE.ID2B)GOTO 8101
C ONLY HANDLE ROWS OR COLS, NOT DIAGONALS.
C MUST BE A PHYS MTX ROW OR COL.
LRINC=0
LCINC=0
IF(RCF.EQ.1)LRINC=1
IF(RCF.EQ.2)LCINC=1
ASSIGN 8108 TO JBACK
GOTO 8109
C COPY DATA
8109 CONTINUE
ICODE=6
IDELT=1
IF(L2.NE.0)IDELT=MAX0(IABS(ID1A-ID1B),IABS(ID2A-ID2B))+1
I1IN=0
I2IN=1
IF(ID1A.EQ.ID1B)GOTO 8106
I1IN=1
I2IN=0
8106 CONTINUE
ID1=ID1A
ID2=ID2A
GOTO JBACK,(8108,8113,8122,8307,8954)
8108 CONTINUE
ICODE=1
IR=NUM1
IC=NUM2
C 1 DIM COPY OF DATA, FOR IDELT ELEMENTS.
DO 8105 NM=1,IDELT
C CLAMP TO MAX DISPLAY ARRAY
IF(IR.GT.20.OR.IC.GT.75)GOTO 8105
NRDSP(IR,IC)=ID1
NCDSP(IR,IC)=ID2
DVS(IR,IC)=DVS(IR,IC)-1.E-14
C THISRW=IR
C THISCL=IC
C JRX=(ID2-1)*60+ID1
CALL REFLEC(ID2,ID1,JRX)
CALL WRKFIL(JRX,FORM2,0)
C READ(7'JRX)FORM2
C DO 7104 N7=1,9
C7104 DFMTS(N7,IR,IC)=FORM2(N7+119)
C DFMTS(10,IR,IC)=0
IR=IR+LCINC
IC=IC+LRINC
C NOTE REVERSAL FOR DISPLAY.
ID1=ID1+I1IN
ID2=ID2+I2IN
8105 CONTINUE
8101 CONTINUE
IF(CMDLIN(2).NE.'F')GOTO 8111
C DF STUFF - SET FORMAT.
ASSIGN 8112 TO IBACK
GOTO 8104
8112 CONTINUE
C NOW HAVE VARIABLE ID'S SET UP
IF(L1.LE.0)GOTO 8120
C MUST HAVE 1 OR MORE...
ASSIGN 8113 TO JBACK
GOTO 8109
C IDELT NOW SET UP. SET FORMATS UP NOW.
C FORMATS ARE IN [] BRACKETS. FIND THESE AND USE.
8113 CONTINUE
ICODE=1
KKK=ICHAR('[')
LA=INDX(CMDLIN,KKK)+1
KKK=ICHAR(']')
LB=INDX(CMDLIN,KKK)-1
LDELT=LB-LA+1
LDELT=MIN0(LDELT,9)
DO 8114 LN=1,IDELT
C IDELT IS OVER VRBL LIST GIVEN. MAY BE 1 ONLY.
C IRRX=(ID2-1)*60+ID1
CALL REFLEC(ID2,ID1,IRRX)
CALL WRKFIL(IRRX,FORM,0)
C READ(7'IRRX)FORM
IF(CMDLIN(LA).EQ.'*')GOTO 7115
IF(CMDLIN(LA).EQ.'A'.OR.CMDLIN(LA).EQ.'L')GOTO 7115
C KEEP EXISTING FORMAT IF [*] IS USED.
DO 7989 KKKK=1,9
7989 FORM(119+KKKK)=Char(0)
DO 8115 LNA=1,LDELT
FORM(LNA+119)=CMDLIN(LA-1+LNA)
IF(LNA.LT.9)FORM(LNA+120)=0
8115 CONTINUE
7115 CONTINUE
C FORM(128)=0
CALL FVLDGT(ID1,ID2,FVWRK)
IVVVV=JCHAR(FVWRK)
IF(IVVVV.EQ.0)IVVVV=3
C SET UP DEFAULT AS NUMERIC.
C IVVVV=FVLD(ID1,ID2)
C FVLD(ID1,ID2)=MAX0(1,IABS(IVVVV))
IVVVV=MAX0(1,IABS(IVVVV))
IF(CMDLIN(LA).EQ.'A'.OR.CMDLIN(LA).EQ.'L')IVVVV=
1 MIN0(-1,-IABS(IVVVV))
CALL FVLDST(ID1,ID2,CHAR(IVVVV))
IF(CMDLIN(LA).EQ.'I')CALL TYPSET(ID1,ID2,4)
IF(CMDLIN(LA).EQ.'F'.OR.CMDLIN(LA).EQ.'E')
1 CALL TYPSET(ID1,ID2,2)
FORM(119)=CHAR(IVVVV)
C
C TO BE SURE WE DON'T FOUL UP THE FILE, TRY AN ENCODE ON THIS FORMAT
C PRIOR TO THE WRITE. THAT WAY IF WE BOMB, THE FILE WE HAVE DIRECT ACCESS
C DATA ON IS NOT CLOBBERED.
IF(IVVVV.LE.0)GOTO 7990
DO 7988 KKK=1,9
KKKK=ICHAR(FORM(119+KKK))
7988 DFE(KKK+1)=CHAR(MAX0(32,KKKK))
DFE(1)='('
DFE(12)=' '
DFE(13)=' '
DFE(14)=')'
CALL TYPGET(N1,N2,TYPE(1,1))
CALL FVLDGT(N1,N2,FVLD(1,1))
d write(*,1092)dfe
d1092 format(' DFE (tst.xqtcmd) format=',14a1,';')
IF(JCHAR(FVLD(1,1)).LE.0)GOTO 7990
IF(TYPE(1,1).NE.2)GOTO 6223
WRITE(WRKCHR(1:127),DFE,ERR=4302)DVS(THISRW,THISCL)
d write(*,1091)dvs(thisrw,thiscl)
d1091 format(' xqtcmd value dvs(here)=',d20.10)
GOTO 7990
6223 CONTINUE
WRITE(WRKCHR(1:127),DFE,ERR=4302)LDVS(1,THISRW,THISCL)
7990 CONTINUE
CALL WRKFIL(IRRX,FORM,1)
DO 8116 NX1=1,20
DO 8116 NX2=1,75
C LOCATE DISPLAY CELL IF ANY
IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8117
8116 CONTINUE
GOTO 8118
8117 CONTINUE
DVS(NX1,NX2)=DVS(NX1,NX2)-1.23E-12
8118 CONTINUE
ID1=ID1+I1IN
ID2=ID2+I2IN
8114 CONTINUE
8111 CONTINUE
IF(CMDLIN(2).NE.'T')GOTO 8120
C DT DISPLAY TYPE
ASSIGN 8121 TO IBACK
GOTO 8104
C GET VBL NAMES
8121 ASSIGN 8122 TO JBACK
GOTO 8109
8122 LA=LSTC+1
IF(L1.LE.0)GOTO 8120
KTYP=2
IF(CMDLIN(LA).EQ.'I')KTYP=4
ICODE=1
DO 8123 LNA=1,IDELT
CALL TYPSET(ID1,ID2,KTYP)
C TYPE(ID1,ID2)=KTYP
DO 8126 NX1=1,DRWV
DO 8126 NX2=1,DCLV
IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8127
C FIND DISPLAY LOC IF ANY AND SET IT UP FOR REDRAW
8126 CONTINUE
GOTO 8128
8127 CONTINUE
DVS(NX1,NX2)=DVS(NX1,NX2)-1.211E-16
8128 CONTINUE
ID1=ID1+I1IN
ID2=ID2+I2IN
8123 CONTINUE
8120 CONTINUE
IF(CMDLIN(2).NE.'W')GOTO 8130
C DW SETS COL WIDTH
ASSIGN 8131 TO KBACK
GOTO 8132
C GET 2 NUMBERS STARTING AT CMDLIN(4)
8132 CONTINUE
KM1=1
KM6=6
CALL GN(KM1,KM6,NCL,CMDLIN(4))
KKK=ICHAR(',')
LA=INDX(CMDLIN(4),KKK)
C COMMA MUST BE SEPARATOR
LCWID=7
IF(LA.GT.100)GOTO 8138
KM1=1
CALL GN(KM1,KM6,LCWID,CMDLIN(LA+4))
8138 GOTO KBACK,(8131,8141)
8131 CONTINUE
ICODE=6
NCL=MAX0(1,NCL)
NCL=MIN0(NCL,20)
LCWID=MAX0(1,LCWID)
LCWID=MIN0(LCWID,110)
C COL WIDTH IS 3 TO 110 CHARS.
IF(NCL.GT.0)CWIDS(NCL)=LCWID
8133 CONTINUE
8130 CONTINUE
IF(CMDLIN(2).NE.'B')GOTO 8140
C DB = BOUNDS ON ROW,COL
ASSIGN 8141 TO KBACK
GOTO 8132
C PARASITE OTHER CODE TO GET DIGITS
8141 MC=NCL
MR=LCWID
MC=MIN0(MC,20)
MR=MIN0(MR,75)
C CLAMP RANGE TO LEGAL
IF(MC.GT.0)DRWV=MC
IF(MR.GT.0)DCLV=MR
ICODE=2
C REDRAW SCREEN WHEN BOUNDS CHANGE.
8140 CONTINUE
GOTO 9990
8002 IF(CMDLIN(1).NE.'V')GOTO 8003
C VIEW REDRAW COMMAND
IF(CMDLIN(2).EQ.'C'.OR.CMDLIN(2).EQ.'B')CALL SWSET(0)
IF(CMDLIN(2).EQ.'I')CALL SWSET(1)
IF(CMDLIN(2).EQ.'C'.OR.CMDLIN(2).EQ.'B')MODFLG=0
IF(CMDLIN(2).EQ.'I')MODFLG=1
C VI MEANS VIEW IBM MODE, USING BIOS CALLS FOR DIRECT SCREEN OUTPUT.
IF(CMDLIN(2).EQ.'C')CALL UVT100(20,0,0)
IF(CMDLIN(2).EQ.'B')CALL UVT100(21,0,0)
C VC SETS VIEW COLOR MODE
C VB SETS VIEW B+W MODE
C REQUIRES UVTGEN MODULE...
PZAP=0
FORMFG=0
IF(CMDLIN(2).EQ.'F')FORMFG=1
IF(CMDLIN(2).EQ.'M')PZAP=1
ICODE=6
GOTO 9990
8003 IF(CMDLIN(1).NE.'C'.AND.CMDLIN(1).NE.'I')GOTO 8004
C COPY NUMBERS COMMAND
C COPY (NUMBERS,FORMAT,DISPLAY,ALL)
C CV=COPY VALUE, CD=COPY DISPLAY FMT, CF=COPY FORMULA, CA=COPY ALL
C Ca V1:V2 V3:V4 COPIES FIRST RANGE TO SECOND.
C IR RANGES DOES INPLACE RELOCATION...
C
C COLLECT ARGS
ASSIGN 8301 TO IBACK
GOTO 8104
8301 CONTINUE
C NOW L1,L2 SAY IF VBLS(ID1A,ID2A) AND (ID1B,ID2B) EXIST
C COLLECT JD2A,JD2B. USE SIMILAR INTERNAL PROCEDURE CODE.
IF(L1.LE.0)GOTO 8399
ASSIGN 8302 TO MBACK
GOTO 8303
8303 CONTINUE
C COLLECT 2 VARS STARTING AT LSTC+3
C SKIPS LSTC DELIMITER.
LJ1=0
LJ2=0
LA=LSTC+1
LE=110-LA
IF(LE.LE.0)GOTO 8304
CALL VARSCN(CMDLIN,LA,LE,LSTC,JD1A,JD1B,IVLD)
LA=LSTC+1
LE=110-LA
IF(LE.LE.0.OR.IVLD.LE.0)GOTO 8304
LJ1=1
IF(CMDLIN(LSTC).NE.':')GOTO 8304
CALL VARSCN(CMDLIN,LA,LE,LSTC,JD2A,JD2B,IVLD)
IF(IVLD.LE.0)GOTO 8304
LJ2=1
8304 GOTO MBACK,(8302)
8302 CONTINUE
IF(LJ1.LE.0)GOTO 8399
IDELT=1
IF(L2.NE.0.AND.(ID1A.NE.ID1B.AND.ID2A.NE.ID2B))GOTO 8305
IF(L2.NE.0)IDELT=MAX0(IABS(ID1A-ID1B),IABS(ID2A-ID2B))+1
8305 CONTINUE
JDELT=1
IF(LJ2.EQ.0)GOTO 8306
IF(JD1A.NE.JD2A.AND.JD1B.NE.JD2B)GOTO 8306
JDELT=MAX0(IABS(JD1A-JD2A),IABS(JD1B-JD2B))+1
8306 IF(L2.NE.0)JDELT=MIN0(IDELT,JDELT)
C CHANGE FOR REPLICATE : JDELT CAN BE JUST JDELT IF L2=0
ASSIGN 8307 TO JBACK
C 8109 IS WHERE WE SET UP I1IN AND I2IN ASSUMING THAT THE VARIABLES
C ARE SET PROPERLY. HANDLED AS AN INTERNAL PROCEDURE.
GOTO 8109
8307 CONTINUE
JIN1=1
JIN2=0
IF(JD1B.EQ.JD2B)GOTO 8308
JIN1=0
JIN2=1
8308 CONTINUE
C CHANGE FOR REPLICATE: IF L2 IS 0 (NO 2ND SRC VARIABLE), NO BUMPS
C PAST THE SINGLE VARIABLE SPECIFIED.
IF(L2.EQ.0)I1IN=0
IF(L2.EQ.0)I2IN=0
C FOR PCC-PC DO RECALC ALWAYS TO ALLOW DISPLAY TO LOOK OK
ICODE=3
C ICODE=1
C FORCE RECALC IF ONLY 1 SOURCE VARIABLE.
C IF(L2.EQ.0)ICODE=3
JRTR=PROW
JRTC=PCOL
C JRTR AND JRTC = RELOCATION THRESHOLDS
C CELLS ABOVE OR LEFT OF JRTR,JRTC WILL NOT BE RELOCATED IN A CR
C OPERATION. THIS WILL GENERALLY BE THE PHYSICAL COLUMN OR ROW
C OF THE CURRENT POSITION. CELLS LOWER OR EQUAL, OR TO THE RIGHT
C OF THE CURRENT LOCATION OR EQUAL, WILL BE RELOCATED. (VARIABLE
C NAMES GET EDITED)
ASSIGN 8365 TO KPYBAK
GOTO 8364
C 8364 BEGINS COPY PROCEDURE SECTION
C GOES FOR JDELT CELLS WITH I1IN AND I2IN BEING SOURCE INCREMENTS FOR
C RRW DIMENSION, RCL DIMENSION, AND JIN1,2 BEING INCREMENTS FOR
C DESTINATION RRW,RCL DIMENSIONS RESPECTIVELY. USES CMDLIN(2) TO
C FLAG WHETHER TO HANDLE ALL, JUST FORMAT, RELOCATE, ETC.
C ALSO ID1A,ID2A ARE START SOURCE LOCATION
C JD1A,JD1B = DEST START LOCATION.
C
C COPIES 1 ROW OR COLUMN AT A TIME.
8364 CONTINUE
C ICODE=1
C SET DISPLAY UPDATE ON COPIED CELLS
CCD DO 3620 JV=1,BRRCL
CCD3620 IBITMP(JV)=0
DO 8309 JV=1,JDELT
DO 8380 NX1=1,DRWV
DO 8380 NX2=1,DCLV
C LOCATE DISPLAY CELL IF ANY
IF(NRDSP(NX1,NX2).EQ.ID1.AND.NCDSP(NX1,NX2).EQ.ID2)GOTO 8387
8380 CONTINUE
GOTO 8388
8387 CONTINUE
DVS(NX1,NX2)=DVS(NX1,NX2)+1.245E-14
8388 CONTINUE
C JRXX=(JD1B-1)*60+JD1A
C IRXX=(ID2A-1)*60+ID1A
CALL REFLEC(JD1B,JD1A,JRXX)
CALL REFLEC(ID2A,ID1A,IRXX)
CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
KKKKK=JCHAR(FVLD(1,1))
CALL FVLDGT(JD1A,JD1B,FVLD(1,1))
IF(KKKKK.EQ.0.AND.ICHAR(FVLD(1,1)).EQ.0)GOTO 8314
C IF(FVLD(ID1A,ID2A).EQ.0.AND.FVLD(JD1A,JD1B).EQ.0)GOTO 8314
CALL WRKFIL(IRXX,FORM,0)
CALL WRKFIL(JRXX,FORM2,0)
IF(KKKKK.EQ.-2)CALL FVLDST(ID1A,ID2A,CHAR(253))
IF(KKKKK.EQ.2)CALL FVLDST(ID1A,ID2A,CHAR(3))
IF(jchar(FORM (119)).EQ. 2)FORM (119)=Char(3)
IF(jchar(FORM (119)).EQ.-2)FORM (119)=Char(253)
IF(jchar(FORM2(119)).EQ. 2)FORM2(119)=Char(3)
IF(jchar(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
IF(CMDLIN(2).NE.'R'.AND.CMDLIN(2).NE.'A')GOTO 8310
IF(CMDLIN(2).NE.'R')GOTO 8366
C RELOCATE, THEN WRITE NEW CELL
II1=ID1A
II2=ID2A
JJ1=JD1A
JJ2=JD1B
CALL RELVBL(FORM,FORM2,II1,II2,JJ1,JJ2,JRTR,JRTC)
C THE ABOVE WILL RELOCATE FORM INTO FORM2 WHICH WE NOW EMIT.
C ALLOW IR COMMAND TO DO INPLACE RELOCATION.
IF(CMDLIN(1).NE.'I')GOTO 6224
CALL WRKFIL(IRXX,FORM2,1)
GOTO 9222
6224 CONTINUE
CALL WRKFIL(JRXX,FORM2,1)
GOTO 8367
8366 CONTINUE
CALL WRKFIL(JRXX,FORM,1)
C WRITE(7'JRXX)FORM
8367 CONTINUE
CALL TYPGET(ID1A,ID2A,TYPE(1,1))
CALL TYPSET(JD1A,JD1B,TYPE(1,1))
C TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A)
CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
CALL XVBLST(JD1A,JD1B,XVBLS(1,1))
C XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A)
CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
CALL FVLDST(JD1A,JD1B,FVLD(1,1))
C FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A)
9222 ID1A=ID1A+I1IN
ID2A=ID2A+I2IN
JD1A=JD1A+JIN1
JD1B=JD1B+JIN2
GOTO 8309
8310 CONTINUE
IF(CMDLIN(2).NE.'V')GOTO 8312
CALL TYPGET(ID1A,ID2A,TYPE(1,1))
CALL TYPSET(JD1A,JD1B,TYPE(1,1))
C TYPE(JD1A,JD1B)=TYPE(ID1A,ID2A)
CALL XVBLGT(ID1A,ID2A,XVBLS(1,1))
CALL XVBLST(JD1A,JD1B,XVBLS(1,1))
C XVBLS(JD1A,JD1B)=XVBLS(ID1A,ID2A)
8312 IF(CMDLIN(2).NE.'D')GOTO 8313
CALL FVLDGT(ID1A,ID2A,FVLD(1,1))
CALL FVLDST(JD1A,JD1B,FVLD(1,1))
C FVLD(JD1A,JD1B)=FVLD(ID1A,ID2A)
DO 8315 LXQ=1,10
8315 FORM2(118+LXQ)=FORM(118+LXQ)
CALL WRKFIL(JRXX,FORM2,1)
C WRITE(7'JRXX)FORM2
8313 IF(CMDLIN(2).NE.'F')GOTO 8314
DO 8316 LXQ=1,110
8316 FORM2(LXQ)=FORM(LXQ)
CALL WRKFIL(JRXX,FORM2,1)
8314 CONTINUE
ID1A=ID1A+I1IN
ID2A=ID2A+I2IN
JD1A=JD1A+JIN1
JD1B=JD1B+JIN2
8309 CONTINUE
C RETURN POINT FROM COPY LOOP IN NORMAL COPY
GOTO KPYBAK,(8840,8836,8365)
8365 CONTINUE
8399 GOTO 9990
8004 IF(CMDLIN(1).LT.'1'.OR.CMDLIN(1).GT.'4')GOTO 8005
C 1,2,3,4 POSITIONING COMMANDS
C USE LLT AND LGT LEXICAL ORDERING TESTS, NOT ARITHMETIC ONES...
ICODE=5
C IF(CMDLIN(1).EQ.'3')THISRW=MAX0(1,(THISRW-1))
C IF(CMDLIN(1).EQ.'4')THISRW=MIN0((THISRW+1),DRWV)
C IF(CMDLIN(1).EQ.'1')THISCL=MAX0(1,(THISCL-1))
C IF(CMDLIN(1).EQ.'2')THISCL=MIN0((THISCL+1),DCLV)
C COULD ADD SCROLLING HERE IF DESIRED.
C ASCII 1,2,3,4 ARE VALUES 49,50,51,52 IN DECIMAL.
MVFG=ICHAR(CMDLIN(1))
LRO=1
LCO=1
ID1=NRDSP(1,1)
ID2=NCDSP(1,1)
IF(.NOT.(MVFG.EQ.51.AND.THISRW.EQ.1))GOTO 2110
C MUST SCROLL LEFT
IF(IDOL7.EQ.0)GOTO 2110
IF(ID1.LE.1)GOTO 2110
ID1=MAX0(1,ID1-DRWV+2)
DROW=MAX0(1,DRWV-2)
IQQ=1
GOTO 7112
2110 IF(MVFG.EQ.51)THISRW=MAX0(1,(THISRW-1))
IF(.NOT.(MVFG.EQ.52.AND.THISRW.EQ.DRWV))GOTO 2116
C MUST SCROLL RIGHT
IF(IDOL7.EQ.0)GOTO 2116
DROW=3
C ID1=MIN0(60,ID1+DRWV-MIN0(DRWV,2))
ID1=ID1+DRWV-MIN0(DRWV,2)
IQQ=1
GOTO 7112
C 7112 FAKES OUT OA CALL TO SCROLL OVER.
2116 IF(MVFG.EQ.52)THISRW=MIN0((THISRW+1),DRWV)
IF(.NOT.(MVFG.EQ.49.AND.THISCL.EQ.1))GOTO 2117
C MUST SCROLL UP
IF(IDOL7.EQ.0)GOTO 2117
IF(ID2.LE.2)GOTO 2117
DCOL=MAX0(1,DCLV-2)
ID2=MAX0(2,ID2-DCLV+2)
IQQ=1
GOTO 7112
2117 IF(MVFG.EQ.49)THISCL=MAX0(1,(THISCL-1))
IF(.NOT.(MVFG.EQ.50.AND.THISCL.EQ.DCLV))GOTO 2118
C MUST SCROLL DOWN
IF(IDOL7.EQ.0)GOTO 2118
DCOL=3
C ID2=MIN0(301,ID2+DCLV-MIN0(DCLV,2))
ID2=ID2+DCLV-MIN0(DCLV,2)
IQQ=1
GOTO 7112
2118 IF(MVFG.EQ.50)THISCL=MIN0((THISCL+1),DCLV)
PROW=NRDSP(THISRW,THISCL)
PCOL=NCDSP(THISRW,THISCL)
DROW=THISRW
DCOL=THISCL
GOTO 9990
8005 CONTINUE
8007 IF(CMDLIN(1).NE.'R')GOTO 8008
IF(CMDLIN(2).NE.'B')GOTO 7333
C RB VAR SETS RELOCATE BOUNDARY TO VAR COORDS
IF(CMDLIN(3).EQ.'*')GOTO 7332
C NORMAL RB COMMAND
C RB VAR USES VAR NAME TO RESET BDY
LO=3
KKKK=20
CALL VARSCN(CMDLIN,LO,KKKK,IV,ID1,ID2,IVALID)
IF(IVALID.LE.0)GOTO 9990
C IGNORE ERRORS
IDOL5=ID1
IDOL6=ID2
GOTO 9990
7332 IDOL5=20000
IDOL6=20000
C RB* RESETS RELOCATE BDY TO END OF SHEET
GOTO 9990
7333 CONTINUE
C RECOMPUTE SHEET.
C RM COMMAND SETS MANUAL FLAG.
RCFGX=0
RCONE=0
IF(CMDLIN(2).NE.'S')GOTO 5114
RRWACT=60
RCLACT=301
5114 CONTINUE
C RCFGX NONZERO INHIBITS RECALCULATION.
C RCONE SET 1 TO FORCE RECALC OF ALL.
C CHANGE FROM OTHER SYNTAX: RF FORCES RECALC, R DOES NOT.
IF(CMDLIN(2).EQ.'F'.OR.CMDLIN(2).EQ.'R')RCONE=1
C NOTE RXF (X=ANY CHAR BUT F) ACTS LIKE OLD VERSION RXF.
C BARE R COMMAND HOWEVER JUST REDOES CALC. F NOW MEANS "FORCE"
C AND SEEMS A BIT MORE MNEMONIC THIS WAY. ALLOW RR COMMAND
C TO WORK AS WELL AS RF.
IF(CMDLIN(2).NE.'R')RCMODE=0
IF(CMDLIN(2).EQ.'E')RCMODE=1
IF(CMDLIN(2).EQ.'I')RCMODE=2
C RE, RI MODE CONTROLS... ALSO RR ACTS LIKE RF BUT STAYS IN
C RE OR RI MODE... RECALC ENTRY OR INCREMENTAL...
IF(CMDLIN(2).EQ.'M')RCFGX=1
ICODE=3
C 3rd char I Inhibits recalc this time but sets modes...
IF(CMDLIN(3).EQ.'I')ICODE=1
GOTO 9990
8008 IF(CMDLIN(1).NE.'K')GOTO 8009
C DROP INTO CALC BARE.
IF(IPSET.NE.0)GOTO 9990
C CAN'T CALL CALC RECURSIVELY
OSWIT=0
ILNFG=0
C ICODE=-1
C CLOSE UNIT 1 JUST IN CASE...
CLOSE(1)
CALL UVT100(11,2,0)
C ERASE DSPLY
KLVL=1
ILNCT=0
C ICODE SET TO 420 SPECIAL CODE TO TELL MAIN PGM TO CALL INTERACTIVE
C CALCULATOR FCN.
ICODE=420
GOTO 9990
8009 IF(CMDLIN(1).NE.'L')GOTO 8010
C LOCATE CURSOR ORIGIN
C FORMAT IS L VARIABLE
C ONLY 1 VARIABLE NAME TO BE ENTERED.
LA=2
LE=30
CALL VARSCN(CMDLIN,LA,LE,LSTC,ID1A,ID2A,IVLD)
L1=IVLD
C ASSIGN 8900 TO IBACK
C GOTO 8104
8900 IF(L1.LT.1)GOTO 9990
3800 PROW=ID1A
PCOL=ID2A
C LOOK UP DISPLAY COORDS IF ANY
ASSIGN 8901 TO NBK
GOTO 7905
8901 CONTINUE
DROW=LR
DCOL=LC
THISRW=LR
THISCL=LC
3801 ICODE=1
GOTO 9990
8010 CONTINUE
IF(CMDLIN(1).NE.'>')GOTO 3802
C >STRING SEARCHES FORMULAE FOR STRING
LA=MIN0(IDOL5,RRWACT)
LB=MIN0(IDOL6,RCLACT)
C NO ACTION UNLESS VALID SEARCH REGION (CURRENT TO RELOC BDY)
C EXISTS.
IF(LA.LT.PROW.OR.LB.LT.PCOL)GOTO 3801
DO 3803 ID1=PROW,LA
DO 3803 ID2=PCOL,LB
ID1A=ID1
ID2A=ID2
CALL FVLDGT(ID1,ID2,FVLD(1,1))
IF(JCHAR(FVLD(1,1)).EQ.0)GOTO 3803
C HAVE VALID CELL HERE, SO GRAB ITS FORMULA AND COMPARE FOR THE ONE
C WE'RE LOOKING FOR. IF CMD LINE STARTS WITH >> ANCHOR THE SEARCH AT 1ST
C COL.
LMX=50
LMN=2
IF(CMDLIN(2).NE.'>')GOTO 3805
LMX=1
LMN=3
3805 CONTINUE
C IRX=(ID2-1)*60+ID1
CALL REFLEC(ID2,ID1,IRX)
CALL WRKFIL(IRX,FORM,0)
CALL CE2A(FORM,FORM2)
DO 3804 IV=1,LMX
KKKK=109-IV
C COMPARE FORMULA TEXT. USE EXISTING SCMP ROUTINE.
CALL SCMP(CMDLIN(LMN),FORM2(IV),KKKK,KKK)
IF(KKK.EQ.1.AND.JCHAR(FORM2(IV)).GT.0)GOTO 3800
IF(JCHAR(FORM2(IV)).LE.0)GOTO 3803
3804 CONTINUE
3803 CONTINUE
C IF WE FALL THROUGH, WE FAILED TO FIND FORMULA SO FORGET IT.
GOTO 3801
3802 CONTINUE
IF(CMDLIN(1).NE.'Z')GOTO 8011
C ZERO COMMAND
C ZA OR ZE V1:V2
IF(CMDLIN(2).NE.'A')GOTO 8950
C ZA = ZERO ALL. BE SURE HE MEANS IT.
CALL UVT100(1,LLDSP,1)
c WRITE(0,8951)
c8951 FORMAT('Really Zero All of sheet [Y/N]?\')
call Vwrt('Really Zero ALL of sheet [Y/N]?',31)
III=IOLVL
C IF(III.EQ.5)III=0
READ(III,8952,END=510,ERR=510)(FORM2(KKI),KKI=1,4)
8952 FORMAT(4A1)
ICODE=6
IF(FORM2(1).NE.'Y'.AND.FORM2(1).NE.'y')GOTO 9990
CALL UVT100(11,2,0)
ICODE=-4
GOTO 9990
8950 IF(CMDLIN(2).NE.'E')GOTO 9990
ASSIGN 8953 TO IBACK
GOTO 8104
C GET NAMES
8953 IF(L1.LE.0)GOTO 9990
ASSIGN 8954 TO JBACK
GOTO 8109
8954 CONTINUE
DO 8955 NI=1,128
8955 FORM2(NI)=0
FORM2(118)=Char(15)
DO 8823 NI=1,9
8823 FORM2(119+NI)=DEFVB(1+NI)
DO 8956 NI=1,IDELT
C IRX=(ID2-1)*60+ID1
CALL REFLEC(ID2,ID1,IRX)
CALL WRKFIL(IRX,FORM2,1)
CALL FVLDST(ID1,ID2,CHAR(0))
CALL XVBLST(ID1,ID2,0.0D0)
IPRS=PROW
IPCS=PCOL
PROW=ID1
PCOL=ID2
ASSIGN 8957 TO NBK
C FIND DISPLAY LOC IF ANY
GOTO 7905
8957 PROW=IPRS
PCOL=IPCS
IF(LR.EQ.0.OR.LC.EQ.0)GOTO 8958
DVS(LR,LC)=DVS(LR,LC)+1.E-11
8958 CONTINUE
ID1=ID1+I1IN
ID2=ID2+I2IN
8956 CONTINUE
GOTO 9990
8011 IF(CMDLIN(1).NE.'X')GOTO 8012
C EXIT TO OS
C SINCE THERE'S NO WORKFILE HERE, MAKE SURE HE MEANS IT...
IF(IPSET.NE.0)GOTO 9990
ICODE=2
CALL UVT100(1,LLDSP,1)
call
1 swrt('Exit now may lose data unless sheet has been saved'
2 ,50)
CALL UVT100(1,LLCMD,1)
call Vwrt('Confirm Exit Request [Y/N]:',27)
III=IOLVL
C IF(IOLVL.EQ.5)III=0
READ(III,8952,END=510,ERR=510)(FORM2(KKI),KKI=1,4)
IF(FORM2(1).NE.'Y'.AND.FORM2(1).NE.'y')GOTO 9990
C END CALL TO GET OUT OF HERE
Close(unit=11)
Close(unit=3)
Call TTYDEI
STOP
C CALL EXIT
8012 IF(CMDLIN(1).NE.'S')GOTO 8013
C SAVE SHEET TO DISK (NEW SET OF DATA)
C NOW JUST PERMITS RESTART...
ICODE=-2
ISTAT=-2
CALL UVT100(11,2,0)
GOTO 9990
8013 IF(CMDLIN(1).NE.'P')GOTO 8014
IRTN=0
CALL PGET(CMDLIN,ICODE,IRTN)
IF(IRTN.EQ.1)GOTO 510
GOTO 9990
8014 CONTINUE
8015 IF(CMDLIN(1).NE.'G')GOTO 8016
C GET INPUT NUMBERS OFF SEQUENTIAL FILE. USE CURRENT ORIGIN
ICODE=2
IRTN=0
CALL PGGET(CMDLIN,ICODE,IRTN)
IF(IRTN.EQ.1)GOTO 510
C FLAG WE NEED AT LEAST ONE FULL CALC BEFORE GOING TO PARTIALS...
C (OK TOO IF IN OLD RCMODE=0 MODE)
RCMODE=-IABS(RCMODE)
GOTO 9990
8016 IF(CMDLIN(1).NE.'W')GOTO 8017
C WRITE (PRINT) SCREEN OUT TO FILE (MAY BE PRINTER)
C CALL DSPSHT(10)
C ICODE=1
ICODE=400
C CODE 10 IS PRINT SECRET CODE TO DSPSHT.
GOTO 9990
8017 CONTINUE
IF(CMDLIN(1).NE.'H')GOTO 5019
IF(IPSET.NE.0)GOTO 9990
IVVV=0
IVVVV=ICHAR(CMDLIN(2))
ivvx=ICHAR(cmdlin(3))
9308 CONTINUE
IF(IVVVV.GE.48.AND.IVVVV.LE.57)IVVV=IVVVV-48
if(ivvx.lt.48.or.ivvx.gt.57)goto 9381
c implement 2 digit help code.
ivvvx=ivvx-48
ivvv=(ivvv*10)+ivvvx
ivvv=min0(ivvv,99)
9381 continue
C SELECT HELP LEVEL 0-9 IF SPECIFIED.
ICODE=30+IVVV
GOTO 9990
5019 CONTINUE
C *** ALLOW EVALUATION OF A CELL TO PERMIT INTERACTIVE COMMAND FILES TO
C *** BE CONTROLLED RATIONALLY. KEYWORD IS "TEST"
IF(CMDLIN(1).NE.'T'.OR.CMDLIN(2).NE.'E')GOTO 4302
C TEST EXPRESSION IS SYNTAX.
C COPY CMDLIN INTO XTNCMD AND FLAG VIA ICODE=430
XTNCNT=0
ICODE=430
DO 4307 N=1,80
4307 XTNCMD(N)=0
C FIRST ZERO OUT EXTERNAL CMD LINE, THEN FILL IN WHAT'S NEEDED.
DO 4303 N=1,79
XTNCMD(N)=CMDLIN(3+N)
C ALLOW "TE <ANY EXPRESSION>" WITH OPTIONAL SPACE. JUST RETURNS VALUE IN
C % VARIABLE.
IF(ICHAR(XTNCMD(N)).LT.32)GOTO 4304
XTNCNT=N
4303 CONTINUE
4304 CONTINUE
XTNCMD(XTNCNT+1)=Char(0)
GOTO 9990
4302 CONTINUE
C LET DOUBLE DOT (..) INDICATE TO GO BACK TO CONSOLE, CLOSING INPUT FILE
IF (CMDLIN(1).EQ.'.'.AND.CMDLIN(2).EQ.'.')GOTO 510
C ELSE PRINT MESSAGE THAT WE DON'T UNDERSTAND THAT ONE & GO ON
C PRINT INVALID CMD MSG IF NOT JUST A SPACE OR C.R.
IF(ICHAR(CMDLIN(1)).GT.32)CALL SWRT('Invalid Command.',16)
GOTO 200
C ERROR ON READIN ADDRESS. REWIND TERMINAL IF USER
C TYPES CTRL Z (EOF), ELSE LEAVE INDIRECT FILES.
510 CONTINUE
C IF(IOLVL.EQ.5)REWIND 5
CLOSE(3)
c CLOSE(11)
Rewind 11
c OPEN(11,FILE='CON:0/0/100/100/Analy Command')
IOLVL=11
GOTO 498
9990 CONTINUE
C HERE CLEAN UP AND RETURN
C FIRST DISPLAY LAST CURRENT COL IN NORMAL VIDEO
IF(IXLSTR.LE.0.OR.IXLSTC.LE.0)GOTO 2000
N1=NRDSP(IXLSTR,IXLSTC)
N2=NCDSP(IXLSTR,IXLSTC)
C IRRX=(N2-1)*60+N1
CALL REFLEC(N2,N1,IRRX)
C REWRITE LAST LOCATION WITH NO REVERSE VIDEO.
C IF(FVLD(N1,N2).EQ.0)GOTO 2000
IF(IXLSTC.GT.DCLV.OR.IXLSTR.GT.DRWV)GOTO 2000
C ONLY REDRAW NUMBERS. DIRECT DISPLAY OR NOTHING GETS IGNORED.
IF(ICODE.LT.0.OR.ICODE.EQ.2)GOTO 2000
C NO SENSE REDRAWING IF WE'RE ABOUT TO ERASE DISPLAY ANYWAY.
IF(ICODE.GT.30)GOTO 2000
J=8
C ADD 6 COLS FOR LABELS
C DROW,DCOL IS CURRENT DISPLAY LOC.
DO 3301 M1=1,IXLSTR
C FIND DISPLAY COLUMN TO USE
3301 J=J+CWIDS(M1)
J=J-CWIDS(IXLSTR)
C USE THISCL+1 TO LET 1ST ROW BE LABELS.
ICCC=IXLSTC+2
C JVTINC = 1 IF VT100, 0 IF VT52
C JVTINC NEEDED SINCE UVT100 FOR VT100 DOES BACKSPACE AT THE SGR ENTRY
C AND THUS WE NEED TO CORRECT FOR IT. THIS WAS FIXED IN THE UVT52
C VERSION AND ITS DESCENDANTS.
IC1POS=N1
IC2POS=N2
IF(PZAP.NE.0)GOTO 2000
CALL UVT100(1,ICCC,J)
C SELECT ROW "IXLSTC", COL "J"
CALL UVT100(13,0,0)
C DESELECT REVERSE VIDEO
CALL FVLDGT(N1,N2,FVLDTP)
ivv=min0(30,cwids(IXLSTR))
IF(ICHAR(FVLDTP).EQ.0)CALL SWRT(BLANKS,IVV)
IF(ICHAR(FVLDTP).EQ.0)GOTO 2000
CALL WRKFIL(IRRX,FORM2,0)
CALL CE2A(FORM2,FORM)
C READ(7'IRRX)FORM
DO 5546 KKKK=1,100
IV=ICHAR(FORM(KKKK))
IV=MAX0(IV,32)
5546 FORM(KKKK)=Char(IV)
IF(JCHAR(FVLDTP).LT.0.OR.FORMFG.NE.0)
1 WRITE(CMDLNA(1:127),8201)(FORM(II),II=1,100)
C FILL IN TEXT FOR FORMULA IF FVLD < 0 HERE; BELOW, FILL IN VALUE TEXT IF FVLD
C > 0.
IF(FORMFG.NE.0)GOTO 4324
C ALWAYS DO FORMULAS IF FORMFG SET (VF MODE).
DO 6302 KKK=1,9
KKKK=ICHAR(FORM(KKK+119))
C KKKK=DFMTS(KKK,IXLSTR,IXLSTC)
6302 DFE(KKK+1)=CHAR(MAX0(32,KKKK))
DFE(11)=char(32)
C 32 = ASCII SPACE
DFE(1)='('
C REMEMBER: NO \ EDITING IN INTERNAL WRITES!
DFE(12)=' '
DFE(13)=' '
DFE(14)=')'
CALL TYPGET(N1,N2,TYPE(1,1))
IF(JCHAR(FVLDTP).LE.0)GOTO 4324
IF(TYPE(1,1).NE.2)GOTO 6226
WRITE(CMDLNA(1:127),DFE,ERR=4324)DVS(IXLSTR,IXLSTC)
GOTO 4324
6226 CONTINUE
WRITE(CMDLNA(1:127),DFE,ERR=4324)LDVS(1,IXLSTR,IXLSTC)
C REDRAW THIS COL. WITHOUT REVERSE VIDEO HERE.
4324 CALL SWRT(CMDLIN,CWIDS(IXLSTR))
C NOTE THIS REDRAWS PREVIOUS COL. IN NORMAL VIDEO.
C NO CARRIAGE CTL
2000 CONTINUE
C NOW COMPLETE ANY CLEANUP.
C SET CMDLIN TO 0 AT START TO INHIBIT ANY MISINTERPRETATION.
C WE USE CMDLIN AS A BUFFER IN REDRAWIND DSPLY SO DON'T LET IT GET
C CLOBBERED.
DO 945 K=1,132
945 CMDLIN(K)=Char(0)
RETURN
END